Back to jkp-ads.com |
Ron de Bruin
|
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
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.
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
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
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
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.