Copy data to Database worksheet

The example macro's on this page 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 the custom LastRow or LastCol and bIsBookOpen_RB function that you can find in the last section on this page. If you want to use the macro examples in your test workbook do not forget to also copy the functions in a standard module of your workbook.

Before you try the code on this page create a xlsm workbook with two sheets named "Sheet1" and "Sheet2" and in "Sheet1" add some values in "A1:K1" so you can test the code examples. Copy the code from this page inside a Normal Module inside this workbook.

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 too 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.


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.xlsx if it is not open (It uses the function bIsBookOpen_RB to check if the workbook is open or not). This workbook must be in the same folder as the workbook with the code in this example.


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.xlsx") Then
Set DestWB = Workbooks("Backup.xlsx")
Else
Set DestWB = Workbooks.Open(ThisWorkbook.Path & "/Backup.xlsx")
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
11-May-2021
Web design by Will Woodgate