PDA

View Full Version : [SOLVED] Auto copy range data and paste on last empty row



Nick Leow
05-25-2018, 12:39 AM
I'm new to VBA and trying to auto copy and paste a range of data from daily production file(2018-05-23.xlsm & 2018-05-24.xlsm) and paste on a master file(Master-3.xlsm) by clicking the "CommandButton1" inside worksheet name "Summary" in Master-3.xlsm.

The VBA code will refer to "C1" value in "Summary" for which file I want to copy so that I can just changing the file name to auto copy the daily production data into Master-3.xlsm. The code will perform autocopy data A490:AJ510 for every sheets inside daily production file into Master-3.xlsm which has the same sheet names.

The problem I'm having:
1) I want to copy rows that have value(ignore formula) until blank row on A490:AJ510 inside every sheet of daily production file. Now the code copy everything into Master-3.xlsm
2) The current data is pasting on A7 in every sheet name of Master-3.xlsm. I want it to detect blank row in column A and paste. Because every sheet will have different blank row in column A after I perform autocopy everyday. It can detect blank row from A7 to A998, because A999 has "END" which I need it due to formula on J column for every sheets in Master-3.xlsm


Private Sub CommandButton1_Click()
Dim aw As Workbook
Dim y As Workbook
Dim sh As Worksheet

Set aw = Application.ActiveWorkbook
Set y = Application.Workbooks.Open(Range("C1").Value)

For i = 1 To aw.Sheets.Count
Set sh = Nothing
On Error Resume Next
Set sh = y.Worksheets(aw.Worksheets(i).Name)
On Error GoTo 0
If TypeName(sh) <> "Nothing" Then
sh.Range("A490:AJ510").Copy
aw.Worksheets(i).Range("A7").PasteSpecial xlPasteValues
End If
Next i
Application.CutCopyMode = False
End Sub



Any help would be very much appreciated!

georgiboy
05-25-2018, 05:03 AM
Welcome to the forum.

How about something like this (untested):

Private Sub CommandButton1_Click()
Dim aw As Workbook
Dim y As Workbook
Dim sh As Worksheet
Dim endRow As Long, rCell As Range
Dim NextRow As Long

Set aw = Application.ActiveWorkbook
Set y = Application.Workbooks.Open(Range("C1").Value)

For i = 1 To aw.Sheets.Count
Set sh = Nothing
On Error Resume Next
Set sh = y.Worksheets(aw.Worksheets(i).Name)
On Error GoTo 0
If TypeName(sh) <> "Nothing" Then
For Each rCell In sh.Range("A490:A510").Cells
If rCell.Value = "" Then
endRow = rCell.Row - 1
Exit For
End If
Next
If endRow = 0 Then endRow = 510
sh.Range("A490:AJ" & endRow).Copy
NextRow = aw.Worksheets(i).Range("A999").End(xlUp).Row + 1
aw.Worksheets(i).Range("A" & NextRow).PasteSpecial xlPasteValues
End If
Next i
Application.CutCopyMode = False
endRow = 0
End Sub

Hope this helps

Nick Leow
05-26-2018, 01:39 PM
Hi Georgiboy,

I have tested your code, but getting run time error 1004, "you can't paste here because of the copy area and paste area aren't the same size"
I get this error on the following line

aw.Worksheets(i).Range("A" & NextRow).PasteSpecial xlPasteValues

Full code in this workbook

Private Sub CommandButton1_Click()
Dim aw As Workbook
Dim y As Workbook
Dim sh As Worksheet
Dim endRow As Long, rCell As Range
Dim NextRow As Long

Set aw = Application.ActiveWorkbook
Set y = Application.Workbooks.Open(Range("C1").Value)

For i = 1 To aw.Sheets.Count
Set sh = Nothing
On Error Resume Next
Set sh = y.Worksheets(aw.Worksheets(i).Name)
On Error GoTo 0
If TypeName(sh) <> "Nothing" Then
For Each rCell In sh.Range("A490:A510").Cells
If rCell.Value = "" Then
endRow = rCell.Row - 1
Exit For
End If
Next
If endRow = 0 Then endRow = 510
sh.Range("A490:AJ" & endRow).Copy
NextRow = aw.Worksheets(i).Range("A999").End(xlUp).Row + 1
aw.Worksheets(i).Range("A" & NextRow).PasteSpecial xlPasteValues
End If
Next i
Application.CutCopyMode = False
endRow = 0
End Sub

georgiboy
05-26-2018, 08:49 PM
Are there merged cells in the source or destination worksheets?

Nick Leow
05-29-2018, 02:28 AM
Yeah, there are merged cells in destination worksheets, after unmerged it the code work pretty well, thanks Georgiboy