VBA to create a worksheet named by cell vaue if error

J

jondavis1987

Active Member
Joined
Dec 31, 2015
Messages
443
Office Version
  1. 2019
Platform
  1. Windows
Below is the full code of the macro i'm using

VBA Code: 
Option Explicit

Sub Open_Workbook()

    Dim srcWB As Workbook
    Dim destWB As Workbook
    Dim fName As String
    Dim lastRow As Long
    
'   Capture current workbook as source workbook
    Set srcWB = ActiveWorkbook

'   Open destination workbook and capture it as destination workbook
    Workbooks.Open "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Misc\Yearly HMA Charts.xlsx"
    Set destWB = ActiveWorkbook
    

'   Unhide_Multiple_Sheets()
    destWB.Sheets("Samples").Visible = True
    destWB.Sheets("Sieves").Visible = True


'   Find last row of Sieve data in destination workbook
    lastRow = destWB.Sheets("Sieves").Cells(Rows.Count, "G").End(xlUp).Row + 1
    
'   Copy Sieve data from source workbook to destination workbook
    srcWB.Sheets("A").Range("G20").Copy
    destWB.Sheets("Sieves").Range("A" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("H20").Copy
    destWB.Sheets("Sieves").Range("B" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("G3").Copy
    destWB.Sheets("Sieves").Range("C" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("G5").Copy
    destWB.Sheets("Sieves").Range("D" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("B6").Copy
    destWB.Sheets("Sieves").Range("E" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("A10:A21").Copy
    destWB.Sheets("Sieves").Range("F" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("D10:D21").Copy
    destWB.Sheets("Sieves").Range("G" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("G21:G32").Copy
    destWB.Sheets("Sieves").Range("H" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("H21:H32").Copy
    destWB.Sheets("Sieves").Range("I" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("D22").Copy
    destWB.Sheets("Sieves").Range("J" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("G47").Copy
    destWB.Sheets("Sieves").Range("K" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("H47").Copy
    destWB.Sheets("Sieves").Range("L" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("C53").Copy
    destWB.Sheets("Sieves").Range("M" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("G48").Copy
    destWB.Sheets("Sieves").Range("N" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("H48").Copy
    destWB.Sheets("Sieves").Range("O" & lastRow).Resize(12, 1).PasteSpecial xlPasteValues
    
'   Find last row of Samples data in desitnation workbook
    lastRow = destWB.Sheets("Samples").Cells(Rows.Count, "A").End(xlUp).Row + 1
    
'   Copy Samples data from source workbook to destination workbook
    srcWB.Sheets("A").Range("G20").Copy
    destWB.Sheets("Samples").Range("A" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("H20").Copy
    destWB.Sheets("Samples").Range("B" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("G3").Copy
    destWB.Sheets("Samples").Range("C" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("G5").Copy
    destWB.Sheets("Samples").Range("D" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("B6").Copy
    destWB.Sheets("Samples").Range("E" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("Sheet2").Range("D31").Copy
    destWB.Sheets("Samples").Range("F" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("Sheet2").Range("E31").Copy
    destWB.Sheets("Samples").Range("G" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("Sheet2").Range("F31").Copy
    destWB.Sheets("Samples").Range("H" & lastRow).PasteSpecial xlPasteValues

'   Hide_Multiple_Sheets()
    destWB.Sheets("Samples").Visible = False
    destWB.Sheets("Sieves").Visible = False
    
'   Save changes and close destination workbook
    destWB.Close SaveChanges:=True
    
 
    Dim srcWB1 As Workbook
    Dim destWB1 As Workbook
    Dim fName1 As String
    Dim lastRows As Long
    Dim destName As String
    Dim wsName As String

'   Capture current workbook as source workbook
    Set srcWB = ActiveWorkbook

'   Set the name of the destination workbook
    destName = Range("F8").Text

'   Set the name of the destination worksheet
    wsName = Range("B6").Text

'   Open destination workbook and capture it as destination workbook
    Workbooks.Open "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Mold Heights\" & destName & ".xlsx"
    Set destWB = ActiveWorkbook
    
'   Find last row of data in desired worksheet of destination workbook
    lastRow = destWB.Sheets(wsName).Cells(Rows.Count, "A").End(xlUp).Row + 1

'   Copy Mold Heights data from source workbook to destination workbook
    srcWB.Sheets("A").Range("G3").Copy
    destWB.Sheets(wsName).Range("A" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("E46").Copy
    destWB.Sheets(wsName).Range("B" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("D22").Copy
    destWB.Sheets(wsName).Range("C" & lastRow).PasteSpecial xlPasteValues

'   Save changes and close destination workbook
    destWB.Close SaveChanges:=True

'   Export source workbook to PDF
    With srcWB
        fName = srcWB.Sheets("A").Range("A!F19").Value
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Asphalt Reports\" & fName, Quality:=xlQualityStandard, _
            includeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    End With

End Sub

Specifically in that code there is a bit that opens a workbook called Mold Heights, finds a worksheet based off of a cell value. Below is the specific code. How do I modify this where if there's not a worksheet that matches wsName it will automatically create one?

VBA Code: 
    Dim srcWB1 As Workbook
    Dim destWB1 As Workbook
    Dim fName1 As String
    Dim lastRows As Long
    Dim destName As String
    Dim wsName As String

'   Capture current workbook as source workbook
    Set srcWB = ActiveWorkbook

'   Set the name of the destination workbook
    destName = Range("F8").Text

'   Set the name of the destination worksheet
    wsName = Range("B6").Text

'   Open destination workbook and capture it as destination workbook
    Workbooks.Open "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Mold Heights\" & destName & ".xlsx"
    Set destWB = ActiveWorkbook
    
'   Find last row of data in desired worksheet of destination workbook
    lastRow = destWB.Sheets(wsName).Cells(Rows.Count, "A").End(xlUp).Row + 1

'   Copy Mold Heights data from source workbook to destination workbook
    srcWB.Sheets("A").Range("G3").Copy
    destWB.Sheets(wsName).Range("A" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("E46").Copy
    destWB.Sheets(wsName).Range("B" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("D22").Copy
    destWB.Sheets(wsName).Range("C" & lastRow).PasteSpecial xlPasteValues

'   Save changes and close destination workbook
    destWB.Close SaveChanges:=True
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Here's a Function you can call to see if wsName exists. I haven't looked at all your code and have not tested this. It may need some tweaking, especially since there are multiple workbooks/worksheets involved and you haven't always used references to them when specifying a range. That made it easiest for me to use workbook.activate in two places below that could be avoided with some worksheet qualifiers.

Something like this (note the function is below the demarcation line. you place it beneath your End Sub line.
' Set the name of the destination workbook
destName = Range("F8").Text
' Open destination workbook and capture it as destination workbook
Workbooks.Open "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Mold Heights\" & destName & ".xlsx"
Set destWB = ActiveWorkbook
' Set the name of the destination worksheet
srcWB.Activate
wsName = Range("B6").Text
destWB.Activate
If Not SheetExists(wsName) Then
With destWB
Worksheets.Add after:=Sheets(Sheets.Count)
activeworksheet.Name = wsName
End With
End If
'rest of sub
'___________________________________________________________________________
Function SheetExists(shName As String) As Boolean
SheetExists = False
For Each sh In .Sheets
If sh.Name = shName Then
SheetExists = True
Exit For
End If
Next sh
End Function
 
Upvote 0
VBA Code: 
    Dim srcWB1 As Workbook
    Dim destWB1 As Workbook
    Dim fName1 As String
    Dim lastRows As Long
    Dim destName As String
    Dim wsName As String

'   Capture current workbook as source workbook
    Set srcWB = ActiveWorkbook

'   Set the name of the destination workbook
    destName = Range("F8").Text

'   Set the name of the destination worksheet
    wsName = Range("B6").Text

'   Open destination workbook and capture it as destination workbook
    Workbooks.Open "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Mold Heights\" & destName & ".xlsx"
    Set destWB = ActiveWorkbook
    



destWB.Activate
If Not SheetExists(wsName) Then
With destWB
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = wsName
End With
End If

So when i run the macro it stops immediately after this and says expected end and doesn't do the rest of it
 
Upvote 0
Nevermind, I figured i forgot to move the function under the line to under the sub. I have that problem solved. Now when it gets to Function SheetExists(shName As String) As Boolean there is an error. The error says variable not found
 
Upvote 0
jondavis1987 said:
Nevermind, I figured i forgot to move the function under the line to under the sub. I have that problem solved. Now when it gets to Function SheetExists(shName As String) As Boolean there is an error. The error says variable not found
Click to expand...
As I said, it may need some tweaking. If you type (w/o the quotes) "?wsName" and press enter in the Immediate Window when you get the error what does it return.
 
Upvote 0
JoeMo said:
As I said, it may need some tweaking. If you type (w/o the quotes) "?wsName" and press enter in the Immediate Window when you get the error what does it return.
Click to expand...

It just highlights Function SheetExists(shName As String) As Boolean
 
Upvote 0
My error, replace the function SheetExists with the one below:
VBA Code: 
Function SheetExists(shName As String) As Boolean
SheetExists = False
For Each sh In ActiveWorkbook.Sheets
    If sh.Name = shName Then
        SheetExists = True
        Exit For
    End If
 Next sh
End Function
 
Upvote 0
I got it. Using my original sub I made these changes

VBA Code: 
'   Open destination workbook and capture it as destination workbook
    Workbooks.Open "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Mold Heights\" & destName & ".xlsx"
    Set destWB = ActiveWorkbook

 On Error GoTo ErrorLabel
 
'   Find last row of data in desired worksheet of destination workbook
    lastRow = destWB.Sheets(wsName).Cells(Rows.Count, "A").End(xlUp).Row + 1

   


ExitLabel:
'   Copy Mold Heights data from source workbook to destination workbook
    srcWB.Sheets("A").Range("G3").Copy
    destWB.Sheets(wsName).Range("A" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("E46").Copy
    destWB.Sheets(wsName).Range("B" & lastRow).PasteSpecial xlPasteValues
    srcWB.Sheets("A").Range("D22").Copy
    destWB.Sheets(wsName).Range("C" & lastRow).PasteSpecial xlPasteValues

'   Save changes and close destination workbook
    destWB.Close SaveChanges:=True

'   Export source workbook to PDF
    With srcWB
        fName = srcWB.Sheets("A").Range("A!F19").Value
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "C:\Users\jdavis\Dropbox\Quality Control\Asphalt\Asphalt Reports\" & fName, Quality:=xlQualityStandard, _
            includeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    End With
Exit Sub
ErrorLabel:
Sheets.Add.Name = wsName
Resume ExitLabel
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
VBA Keeps Skipping a Paste
2
Replies
11
Views
730
jondavis1987
J
T
  • Solved
VBA code cannot find sheet name
2
Replies
11
Views
184
jolivanes
jolivanes
Z
  • Question
Questions on VBA
Replies
5
Views
133
DanteAmor
DanteAmor
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
191
ItalianPlatinum
I
S
  • Question
For Loop with If Statement Assistance
Replies
0
Views
233
smick
S

Forum statistics

Threads
1,215,061
Messages
6,122,921
Members
449,094
Latest member
teemeren

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top