vendredi 11 septembre 2015

Create new worksheet if does not exist, rename based on cell value, then reference that worksheet

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