Ron de Bruin
Excel Automation

Copy to a Database sheet with VBA

Important message to visitors of this page

Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.

Luckily, Ron was kind enough to allow me to publish all of his Excel content here.

Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.

Kind regards

Jan Karel Pieterse

The example macro's will copy data from "Sheet1" to a Database sheet with the name "Sheet2". Every time you run one of the macros the cells will be placed below the last row with data or after the last Column with data in the database sheet named "Sheet2" in this example.

Important: The macro examples use one function or more than one of the functions that you can find in the last section of this page. Do not forget to copy the functions in your workbook a Standard module of your workbook, if you just started with VBA see this page.
Where do I paste the code that I find on the internet

Copy a range with one area below the last row

Three examples to do this:

1: The first one copies everything
2: The second one uses the value property and will only copy the values.
3: The third one uses PasteSpecial to copy only the values.
See help for more information about the options for PasteSpecial. The PasteSpecial macro's can also be used to transpose the range that you copy, change the last argument to True if you want that.

Note 1: Change the SourceRange and DestSheet in the macros.
Note 2: The three macros in this section use the function LastRow.

Sub Copy_1()
    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 = Sheets("Sheet1").Range("A1:K1")

    'Fill in the destination sheet and call the LastRow
    'function to find the last row
    Set DestSheet = Sheets("Sheet2")
    Lr = LastRow(DestSheet)

    'With the information from the LastRow function we can
    'create a destination cell and copy/paste the source range
    Set DestRange = DestSheet.Range("A" & Lr + 1)
    SourceRange.Copy DestRange

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

End Sub


Sub Copy_1_Value_Property()
    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 = Sheets("Sheet1").Range("A1:K1")

    'Fill in the destination sheet and call the LastRow
    'function to find the last row
    Set DestSheet = Sheets("Sheet2")
    Lr = LastRow(DestSheet)

    'With the information from the LastRow function we can create a
    'destination cell
    Set DestRange = DestSheet.Range("A" & Lr + 1)

    '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

End Sub


Sub Copy_1_Value_PasteSpecial()
    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 = Sheets("Sheet1").Range("A1:K1")

    'Fill in the destination sheet and call the LastRow
    'function to find the last row
    Set DestSheet = Sheets("Sheet2")
    Lr = LastRow(DestSheet)

    'With the information from the LastRow function we can
    'create a destination cell
    Set DestRange = DestSheet.Range("A" & Lr + 1)

    'Copy the source range and use PasteSpecial to paste in
    'the destination cell
    SourceRange.Copy
    DestRange.PasteSpecial _
            Paste:=xlPasteValues, _
            operation:=xlPasteSpecialOperationNone, _
            skipblanks:=False, _
            Transpose:=False
    Application.CutCopyMode = False

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

End Sub

Note: in the last macro you can also use xlPasteValuesAndNumberFormats so it also copy the numberformats to the database sheet.

Copy a range with more then one area below last row

Tip: Use a row below your data with links to cells you want (=C3 in A50, =G15 in B50, …..).
You can hide this row if you want and copy a range like A50:Z50 for example with one of the
one area examples above.

Here are two examples that use the Value property to copy a range with more then one area

Note 1: Change the SourceRange and DestSheet in the macros.
Note 2: The two examples in this section use the function LastRow.

Sub Copy_Next_Each_Other()
    Dim smallrng As Range, DestRange As Range
    Dim DestSheet As Worksheet, Lr As Long
    Dim SourceRange As Range, I As Integer

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

    'fill in the Source Sheet and range
    Set SourceRange = Sheets("Sheet1").Range("A1,A3,A8")

    'Fill in the destination sheet and call the LastRow
    'function to find the last row
    Set DestSheet = Sheets("Sheet2")
    Lr = LastRow(DestSheet)
    I = 1

    For Each smallrng In SourceRange.Areas

        'We make DestRange the same size as smallrng and use the
        'Value property to give DestRange the same values
        With smallrng
            Set DestRange = DestSheet.Cells(Lr + 1, I) _
                            .Resize(.Rows.Count, .Columns.Count)
        End With
        DestRange.Value = smallrng.Value
        I = I + smallrng.Columns.Count

    Next smallrng

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

End Sub


Sub Copy_Below_Each_Other()
    Dim smallrng As Range, DestRange As Range
    Dim DestSheet As Worksheet, Lr As Long
    Dim SourceRange As Range

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

    'fill in the Source Sheet and range
    Set SourceRange = Sheets("Sheet1").Range("A1,A3,A8")

    'Fill in the destination sheet
    Set DestSheet = Sheets("Sheet2")

    For Each smallrng In SourceRange.Areas

        'We make DestRange the same size as smallrng and use the
        'Value property to give DestRange the same values
        With smallrng
            Set DestRange = DestSheet.Range("A" & LastRow(DestSheet) + 1) _
                            .Resize(.Rows.Count, .Columns.Count)
        End With
        DestRange.Value = smallrng.Value

    Next smallrng

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

End Sub

Copy a range with one area after the last column

Note 1: Change the SourceRange and DestSheet in the macros.
Note 2: The example in this section use the function LastCol.

Remember that Excel 97-2003 have only 256 columns.
Excel 2007-2013 have 16384 columns.

Sub Copy_Column_Value_Property()
    Dim SourceRange As Range, DestRange As Range
    Dim DestSheet As Worksheet, Lc As Long

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

    'fill in the Source Sheet and range
    Set SourceRange = Sheets("Sheet1").Range("A1:A5")

    'Fill in the destination sheet and call the LastCol
    'function to find the last column
    Set DestSheet = Sheets("Sheet2")
    Lc = LastCol(DestSheet)

    'We make DestRange the same size as SourceRange and use
    'the Value property to give DestRange the same values
    With SourceRange
        Set DestRange = DestSheet.Cells(1, Lc + 1) _
                        .Resize(.Rows.Count, .Columns.Count)
    End With
    DestRange.Value = SourceRange.Value

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

End Sub

What if the Database sheet is in another workbook

Here is a example that uses the Value property to copy a range to another file

Note 1: Change the SourceRange and DestSheet and path/file name in the macros.
Note 2: The example in this section use the functions LastRow and bIsBookOpen_RB.

The macro will open the database workbook Backup.xls if it is not open (It uses the function bIsBookOpen_RB to check if the workbook is open or not).

Sub Copy_To_Another_Workbook()
    Dim SourceRange As Range
    Dim DestRange As Range
    Dim DestWB As Workbook
    Dim DestSh As Worksheet
    Dim Lr As Long

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

    'Change the file name (2*) and the path/file name to your file
    If bIsBookOpen_RB("Backup.xls") Then
        Set DestWB = Workbooks("Backup.xls")
    Else
        Set DestWB = Workbooks.Open("C:\Users\Ron\test\Backup.xls")
    End If

    'Change the Source Sheet and range
    Set SourceRange = ThisWorkbook.Sheets("Sheet1").Range("A1:K1")
    'Change the sheet name of the database workbook
    Set DestSh = DestWB.Worksheets("Sheet1")


    Lr = LastRow(DestSh)
    Set DestRange = DestSh.Range("A" & Lr + 1)

    '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

    DestWB.Close savechanges:=True

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

Common Functions required for all routines

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function


Function bIsBookOpen_RB(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen_RB = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Instead of a function you can also check one row or column to find the last cell with a value.

Replace this line:
Lr = LastRow(DestSheet)

With:
Lr = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row
This will give you the last row with data in Column A

Or replace this line
Lc = LastCol(DestSheet)

With:
Lc = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column
This will give you the last column with data in Row 1

Be aware that if you copy a range that has empty cells in it, It is possible that the next time you copy
to Sheets("Sheet2") some lines will be overwritten. Use the Functions to avoid this kind of problems.

Copyright © 2022 Ron de Bruin

Site designed by Spider Web Woman Designs