Excel VBA Code for Copy & Paste Without Header, Paste in Last Row

[jxj_00]

Hi, please help as I am very new to VBA.

I need to copy and paste from Workbook 1, Worksheet 1 to Workbook 2, Worksheet 2.
There are 2 main things I need to achieve with the code.
1. Copy from WB1, WS1 from row 4 to WB2, WS2 row 4 (As I have headers & macro buttons above)
2. Paste to WB2, WS2 at the last empty row

The code runs successfully.
However, it tells me to select a destination and press enter. However, the code I have written is supposed to add it to last empty row.

Please help and thank you in advance!

Sub Copy_Without_Header()

'Delete Empty Rows'
On Error Resume Next
Range("B3:B" & Workbooks("WB1.xlsm").Worksheets("WS1"). _
UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Copy without header'
Workbooks("WB1.xlsm").Worksheets("WS1"). _
Range("A4").CurrentRegion.Offset(1, 0).Resize(Range("A4").CurrentRegion.Rows.Count - 1).Copy

'Paste in last empty row'
Workbooks("WB2.xlsm").Worksheets("WS2"). _
Range("A4").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

End Sub

 

[mumps]

The 'Delete Empty Rows' part of you code doesn't specify in which worksheet you are deleting the rows.

Copy from WB1, WS1 from row 4

Do you want to copy starting at row 4 or starting at row 5? This part of your code:

Workbooks("WB1.xlsm").Worksheets("WS1").Range("A4").CurrentRegion.Offset(1, 0).Resize(Range("A4").CurrentRegion.Rows.Count - 1).Copy

will start copying at row 5. Also, it's hard to work with a picture. Please use the XL2BB add-in (icon in the menu) to attach screenshots (not a picture) of your two sheets. Alternately, you could upload a copy of your files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[jxj_00]

The 'Delete Empty Rows' part of you code doesn't specify in which worksheet you are deleting the rows.
Do you want to copy starting at row 4 or starting at row 5? This part of your code:

Workbooks("WB1.xlsm").Worksheets("WS1").Range("A4").CurrentRegion.Offset(1, 0).Resize(Range("A4").CurrentRegion.Rows.Count - 1).Copy

will start copying at row 5. Also, it's hard to work with a picture. Please use the XL2BB add-in (icon in the menu) to attach screenshots (not a picture) of your two sheets. Alternately, you could upload a copy of your files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

I want to delete the empty rows in WB1. As the dates may sometimes be left empty hence I used column B as part of the code.

I want to start copying at row 4.

I have uploaded the file to box.com as advised. This is the link: Box

So what I want to do is to write a code where it will allow me to copy from the 4 row onwards in WB1 (So copy from 4th to last filled row). Then it will copy to the last empty row of WB2 as WB2 may or may not have data inside.

I appreciate the clear instruction you have provided. Hope that I have explained it clearly.

Thank you!

 

[mumps]

Re-name the sheet in WB2 as "WS2" and place this macro in WB1.

Sub Copy_Without_Header()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, LastRow As Long
    Set srcWS = ThisWorkbook.Sheets("WS1")
    Set desWS = Workbooks("WB2.xlsm").Sheets("WS2")
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With srcWS
        If WorksheetFunction.CountA(.Range("B4:B" & .UsedRange.Rows.Count + 2)) < .UsedRange.Rows.Count - 1 Then
            .Range("B4:B" & .UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End If
        .Range("A4").CurrentRegion.Offset(1).Resize(.Range("A4").CurrentRegion.Rows.Count).Copy
    End With
    desWS.Range("A" & LastRow).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[jxj_00]

Re-name the sheet in WB2 as "WS2" and place this macro in WB1.

Sub Copy_Without_Header()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, LastRow As Long
    Set srcWS = ThisWorkbook.Sheets("WS1")
    Set desWS = Workbooks("WB2.xlsm").Sheets("WS2")
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With srcWS
        If WorksheetFunction.CountA(.Range("B4:B" & .UsedRange.Rows.Count + 2)) < .UsedRange.Rows.Count - 1 Then
            .Range("B4:B" & .UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End If
        .Range("A4").CurrentRegion.Offset(1).Resize(.Range("A4").CurrentRegion.Rows.Count).Copy
    End With
    desWS.Range("A" & LastRow).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

The code ran successfully without any hiccups. Thank you!

 

[mumps]

You are very welcome.

 

[jxj_00]

You are very welcome.

Hi, may I check if it is possible to add to the code ontop to delete the copied information from WB1?

I have tried changing the code of copy to cut but it shows an error.

 

[mumps]

Try:

Sub Copy_Without_Header()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, LastRow As Long
    Set srcWS = ThisWorkbook.Sheets("WS1")
    Set desWS = Workbooks("WB2.xlsm").Sheets("WS2")
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With srcWS
        If WorksheetFunction.CountA(.Range("B4:B" & .UsedRange.Rows.Count + 2)) < .UsedRange.Rows.Count - 1 Then
            .Range("B4:B" & .UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End If
        .Range("A4").CurrentRegion.Offset(1).Resize(.Range("A4").CurrentRegion.Rows.Count).Copy
        desWS.Range("A" & LastRow).PasteSpecial xlPasteValuesAndNumberFormats
        .Range("A4").CurrentRegion.Offset(1).Resize(.Range("A4").CurrentRegion.Rows.Count).ClearContents
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Also, when replying, please click the "Reply" button not the "Reply with Quote" button. This avoids clutter.

 

[jxj_00]

Thanks, the code ran well. Appreciate for letting me know about the reply option

 

[mumps]

You are very welcome.