Create worksheet in masterfile and add content below existing content

**Hond70** · 10-19-2011, 03:06 AM

Context: each employee uses the same worksheet stored on a network drive to fill in their daily activities. I want to capture these activities into one masterfile.
I have found some very neat code to copy the content of a worksheet into a seperate masterfile.
Now I want to:
1. create a new sheet in the masterfile (if it doesn't exist) based on the value of cell B7 in the worksheet (a date)
2. in the new sheet of step 1, find the last row that is filled in, leave a row blank and then copy the content of the worksheet into that new sheet (e.g. in the workbook Tom presses CommandButton9 first and copies his activities to A1:M11 in the new sheet of the masterfile, then Frank presses CommandButton9 and copies his activities to A13:M23 etcetera)
How can I accomplish that?
See here for my workbook

Private Sub CommandButton9_Click()
    Dim IntSht As Worksheet
    Dim IntBk As Workbook
    Dim ExtBk As Workbook
    Dim ExtFile As String
     
    Set IntBk = ActiveWorkbook
    Set IntSht = IntBk.ActiveSheet
    ExtFile = "N:\Uren\Master Workbook.xls"
    'Example of dynamic filename: wbName = "NAV SHEET " & Format(Date, "ddmmyy") & ".xls"
    If Dir(ExtFile) <> "" Then
    Else
        ExtFile = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Please Select A File")
    End If
    On Error Resume Next
    Set ExtBk = Workbooks(Dir(ExtFile))
    On Error GoTo 0
    If ExtBk Is Nothing Then
        Application.Workbooks.Open ExtFile
        Set ExtBk = Workbooks(Dir(ExtFile))
    End If

'Copy Sheet content to new workbook
'Original line:    IntBk.IntSht.Range("DataDump").Copy ExtBk.Worksheets("Raw Data").Range("A" & Rows.Count).End(xlUp).Offset(1)
    IntSht.Range("A11:M21").Copy ExtBk.Worksheets("Sheet1").Range("A1:M11")
    Application.DisplayAlerts = False
    ExtBk.Save
    ExtBk.Close
    Application.DisplayAlerts = True
    Call CreateEmail
    CommandButton9.Enabled = False
End Sub

This code should be integrated above to create a sheet if it doesn't exist

'Create sheetname
Dim strSheetName As String
Dim wsTest As Worksheet
 
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
 
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
MsgBox "Sheet " & strSheetName & " created."
End If
 
'Create worksheet with "Bob" if it doesn't exist.
CreateSheet "Bob"

**Hond70** · 10-20-2011, 09:21 AM

I did it! Great! Thanks Google...

Private Sub CommandButton9_Click()
    Dim IntSht As Worksheet
    Dim IntBk As Workbook
    Dim ExtBk As Workbook
    Dim ExtFile As String

'Name workbooks and open external workbook
    Set IntBk = ActiveWorkbook
    Set IntSht = IntBk.ActiveSheet
    'ExtFile = "N:\Uren\Master Workbook.xls"
    ExtFile = "F:\Master Workbook.xls"
    If Dir(ExtFile) <> "" Then
    Else
        ExtFile = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Please Select A File")
    End If
    On Error Resume Next
    Set ExtBk = Workbooks(Dir(ExtFile))
    On Error GoTo 0
    If ExtBk Is Nothing Then
        Application.Workbooks.Open ExtFile
        Set ExtBk = Workbooks(Dir(ExtFile))
    End If

'Set sheetname based on value B7 in active sheet
    Dim strSheetName As String
    strSheetName = IntSht.Range("B7").Value

'Check if sheet with value B7 exists, if not then create sheet
    Dim wsTest As Worksheet
 
    Set wsTest = Nothing
    On Error Resume Next
    Set wsTest = ExtBk.Worksheets(strSheetName)
    On Error GoTo 0
 
    If wsTest Is Nothing Then
    ExtBk.Worksheets.Add.Name = strSheetName
    End If

'Copy range: http://www.rondebruin.nl/copy1.htm
    Dim SourceRange As Range, DestRange As Range
    Dim DestSheet As Worksheet, Lr As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

'fill in the Source Sheet and range
    Set SourceRange = IntSht.Range("B11:N21")

'Fill in the destination sheet and call the LastRow
'function to find the last row
    Set DestSheet = ExtBk.Worksheets(strSheetName)
    Lr = DestSheet.Cells(Rows.Count, "B").End(xlUp).Row

'With the information from the LastRow function we can create a
'destination cell and copy the data from one range to another
    Set DestRange = DestSheet.Range("A" & Lr + 2)
    SourceRange.Copy DestRange
    'We make DestRange the same size as SourceRange and use the Value
    'property to give DestRange the same values
'    With SourceRange
'        Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
'    End With
'    DestRange.Value = SourceRange.Value

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

'Old way to copy Sheet content to new workbook
'Original line:    IntBk.IntSht.Range("DataDump").Copy ExtBk.Worksheets("Raw Data").Range("A" & Rows.Count).End(xlUp).Offset(1)
'Or: IntSht.Range("A11:M21").Copy ExtBk.Worksheets("Sheet1").Range("A1:M11")

    Application.DisplayAlerts = False
    ExtBk.Save
    ExtBk.Close
    Application.DisplayAlerts = True
'    Call CreateEmail
'    CommandButton9.Enabled = False
End Sub