I have 2 workbooks one has the vba (MainWb), the other is just a template (TempWb) that the code paste values and formulas from the mainworkbook. The TempWb only has one blank sheet named graphs. The code needs to open the xltx file (TempWb), add a sheet and rename based on value in a certain cell on the MainWb (if it does not already exist) and then to reference that new sheet in the copy values process from the MainWb. I tried recording a macro but it didn't really help. I have researched and put some stuff together but not sure if it fits and works. Any suggestions would be appreciated.
This is what I have so far.
Option Explicit
Sub ExportSave()
Dim Alpha As Workbook 'Template
Dim Omega As Worksheet 'Template
Dim wbMain As Workbook 'Main Export file
Dim FileTL As String 'Test location
Dim FilePath As String 'File save path
Dim FileProject As String 'Project information
Dim FileTimeDate As String 'Export Date and Time
Dim FileD As String 'Drawing Number
Dim FileCopyPath As String 'FileCopy save path
Dim FPATH As String 'File Search Path
Dim Extract As Workbook 'File Extract Data
Dim locs, loc 'Location Search
Dim intLast As Long 'EmptyCell Search
Dim intNext As Long 'EmptyCell Seach
Dim rngDest As Range 'Paste Value Range
Dim Shtname1 As String 'Part Platform
Dim Shtname2 As String 'Part Drawing Number
Dim Shtname3 As String 'Part Info
Dim rep As Long
With Range("H30000")
.Value = Format(Now, "mmm-dd-yy hh-mm-ss AM/PM")
End With
FilePath = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test"
FileCopyPath = "C:\Users\aholiday\Desktop\Backup"
FileTL = Sheets("Sheet1").Range("A1").Text
FileProject = Sheets("Sheet1").Range("E2").Text
FileTimeDate = Sheets("Sheet1").Range("H30000").Text
FileD = Sheets("Sheet1").Range("E3").Text
FPATH = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\"
Shtname1 = wbMain.Sheets("Sheet1").Range("E2")
Shtname2 = wbMain.Sheets("Sheet1").Range("E3")
Shtname3 = wbMain.Sheets("Sheet1").Range("E4")
Select Case Range("A1").Value
Case "Single Test Location"
Case "Location 1"
Application.DisplayAlerts = False
Set wbMain = Workbooks("FRF Data Export Graphs.xlsm")
wbMain.Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs FileName:=FileCopyPath & "\" & FileProject & Space(1) & FileD & Space(1) & FileTL & Space(1) & FileTimeDate & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close False
Set Alpha = Workbooks.Open("\\plymshare01\Public\Holiday\FRF Projects\Templates\FRF Data Graphs.xltx")
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep)).Name = LCase(Shtname1 & Space(1) & Shtname2 & Space(1) & Shtname3) Then
MsgBox "This Sheet already exists"
Exit Sub
End If
Next
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = Shtname1 & Space(1) & Shtname2 & Space(1) & Shtname3
Set Omega = Workbooks(ActiveWorkbook.Name).Sheets("ActiveWorksheet.Name")
locs = Array("FRF Data Export Graphs.xlsm")
'set the first data block destination
Set rngDest = Omega.Cells(3, 1).Resize(30000, 3)
For Each loc In locs
Set Extract = Workbooks.Open(FileName:=FPATH & loc, ReadOnly:=True)
rngDest.Value = Extract.Sheets("Sheet1").Range("A4:D25602").Value
Extract.Close False
Set rngDest = rngDest.Offset(0, 4) 'move over to the right 4 cols
Next loc
With ActiveWorksheet.Range("D3:D25603").Formula = "=SQRT((B3)^2+(C3)^2)"
ActiveWorkbook.Charts.Add
ActiveChart.ChartType = xlXYScatterLines
ActiveChart.SetSourceData Source:=Sheets("Graphs").Range("A3:D7"), PlotBy:=xlRows
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:=Shtname2
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = Shtname2
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Hz"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Blank"
End With
Application.ScreenUpdating = True
Case "Location 2"
Case "Location 3"
Case "Location 4"
Case Else
MsgBox "Export Failed!"
End Select
Application.DisplayAlerts = True
End Sub
Run-time error '91' Object variable or With block not set code lines
Shtname1 = wbMain.Sheets("Sheet1").Range("E2")
Shtname2 = wbMain.Sheets("Sheet1").Range("E3")
Shtname3 = wbMain.Sheets("Sheet1").Range("E4")
This is supposed to tell the code what to name the new created sheet
Fixed: Moved under
Set = wbMain = Workbooks("FRF Data Export Graphs.xlsm")
New Error: Object doesnt support this property or method code
If LCase(Sheets(rep)).Name = LCase(Shtname1 & Space(1) & Shtname2 & Space(1) & Shtname3) Then
via Chebli Mohamed
Aucun commentaire:
Enregistrer un commentaire