VBA to Copy Rows Until Blank Row

[Shanaka Fernando]

how to copy row value until blank row to my VBA Code.( only highlighted area)

Sub MoveToDestination()

Dim destinationSheet As Worksheet, destRow As Long, destCol As Variant
Dim ws As Worksheet, wsRow As Long, wsCol As Variant
Dim columnHeader As Variant

Set destinationSheet = ThisWorkbook.Worksheets("data")

For Each ws In ThisWorkbook.Worksheets
If Not ws Is destinationSheet Then
For Each columnHeader In Array("ITEM#", "Item description")
With ws
wsCol = Application.Match(columnHeader, .Rows(17), 0)
If Not IsError(wsCol) Then
wsRow = .Cells(.Rows.Count, wsCol).End(xlUp).Row
destCol = Application.Match(columnHeader, destinationSheet.Rows(1), 0)
destRow = destinationSheet.Cells(destinationSheet.Rows.Count, destCol).End(xlUp).Row + 1
.Range(.Cells(18, wsCol), .Cells(wsRow, wsCol)).Copy destinationSheet.Cells(destRow, destCol)
Else
MsgBox "Column heading " & columnHeader & " not found in row 1 of " & .Name
End If
End With
Next
End If
Next
End Sub

 

[Zot]

If Item Description is always next to the Item# then you can just use Resize.
Note that I changed If Not ws Is destinationSheet Then to If Not ws.Name = destinationSheet.Name Then since it causing error. I wonder if yours was working.

Sub MoveToDestination()

Dim destinationSheet As Worksheet, destRow As Long, destCol As Variant, x As Long
Dim ws As Worksheet, wsRow As Long, wsCol As Variant
Dim columnHeader As Variant

Set destinationSheet = ThisWorkbook.Worksheets("data")

For Each ws In ThisWorkbook.Worksheets
    If Not ws.Name = destinationSheet.Name Then
        For Each columnHeader In Array("ITEM#")
            With ws
                wsCol = Application.Match(columnHeader, .Rows(17), 0)
                If Not IsError(wsCol) Then
                    wsRow = .Cells(.Rows.Count, wsCol).End(xlUp).Row
                    destCol = Application.Match(columnHeader, destinationSheet.Rows(1), 0)
                    destRow = destinationSheet.Cells(destinationSheet.Rows.Count, destCol).End(xlUp).Row + 1
                    .Cells(18, wsCol).Resize(wsRow - 18 + 1, 2).Copy destinationSheet.Cells(destRow, destCol)
                Else
                    MsgBox "Column heading " & columnHeader & " not found in row 1 of " & .Name
                End If
            End With
        Next
    End If
Next

End Sub

 

[Shanaka Fernando]

THANKS FOR YOUR REPLY

i need to change the above my vba code to copy row value until first blank row

example - need copy
header "Item description" until "women bikini 2p hang"

how to change my code

 

[Zot]

Try this
Change
.Cells(18, wsCol).Resize(wsRow - 18 + 1, 2).Copy destinationSheet.Cells(destRow, destCol)

to
.Cells(17, wsCol).Resize(wsRow - 17 + 1, 2).Copy destinationSheet.Cells(destRow, destCol)

 

[Shanaka Fernando]

thanks for your reply
' it s not working
please support me

i need stop copy range until first blank row in column "A" how can i change above my vba code
ex - no need to copy values in highlighted area

 

[Zot]

I was looking at your code and your sheet showed your data started on row 17 like below

PUMA.xlsm
	A	B	C	D	E	F
16
17	BARCODE#	ITEM#	Item description	Size	xs
18	'8720245131049	F603021001009010	PUMA WOMEN BIKINI 2P HANG	S
19	'8720245131056	F603021001009020	PUMA WOMEN BIKINI 2P HANG	M
20	'8720245131063	F603021001009030	PUMA WOMEN BIKINI 2P HANG	L
21	'8720245131070	F603021001009040	PUMA WOMEN BIKINI 2P HANG	XL
22
23			Total qty :		336
24			Total cn :		4
25			Total gross weight:		0
26			Total net weight:		-4.8
27			Total net net weight:		-5
28			Total volume in cubic mts:		0
29
Sheet1

Your destination sheet is named Data. which I believed row 2 (probably excluding headers)

Do you want to copy column A, B, and C only? Like this? Please clarify

PUMA.xlsm
	A	B	C	D	E
1	BARCODE#	ITEM#	Item description	Size	xs
2	'8720245131049	F603021001009010	PUMA WOMEN BIKINI 2P HANG
3	'8720245131056	F603021001009020	PUMA WOMEN BIKINI 2P HANG
4	'8720245131063	F603021001009030	PUMA WOMEN BIKINI 2P HANG
5	'8720245131070	F603021001009040	PUMA WOMEN BIKINI 2P HANG
6
data

 

[Shanaka Fernando]

my destination sheet is Data

row 17 is header of all sheets.( i have multiple sheet with a difference sheet name in the workbook and the worksheets are changed (with name) Daily)

* no need copy below area (example - stop copy row column A until 1st blank row). i have attached two sheet Picture.

 

[Zot]

Sorry for late response. I was on leave yesterday.

For this line

wsCol = Application.Match(columnHeader, .Rows(17), 0)
      If Not IsError(wsCol) Then

If columnHeader is not found, the execution will stop right there. So, there is no chance that If Not IsError(wsCol) will be executed.

Therefore I rewrote the code.

Option Compare Text

Sub MoveToDestination()

Dim wsRow As Long, wsCol As Long, DestRow As Long, DestCol As Long
Dim colHeader As Variant, ArryColDest() As Variant
Dim rngHeader As Range, rngDest As Range
Dim ws As Worksheet, wsDest As Worksheet

Application.ScreenUpdating = False

Set wsDest = ActiveWorkbook.Worksheets("Data")
Set rngDest = wsDest.Range("A1", "C1")

' Setup Destination Header
wsDest.Range("A1") = "Item Description"
wsDest.Range("B1") = "Item #"
wsDest.Range("C1") = "Color"

For Each ws In ActiveWorkbook.Sheets
    Set rngHeader = ws.Range("A17", "M17")
    DestRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
    If Not ws.Name = wsDest.Name Then
        For Each colHeader In Array("Item Description", "Item #", "Color")
            DestCol = Application.Match(colHeader, rngDest, 0)
            With ws
                If Not IsError(Application.Match(colHeader, rngHeader, 0)) Then
                    wsCol = Application.Match(colHeader, rngHeader, 0)
                    If Not .Cells(18, wsCol) = "" Then
                        wsRow = .Cells(17, wsCol).End(xlDown).Row
                    End If
                    .Range(.Cells(18, wsCol), .Cells(wsRow, wsCol)).Copy
                    wsDest.Cells(DestRow, DestCol).PasteSpecial (xlPasteValuesAndNumberFormats)
                Else
                    MsgBox "Column heading " & colHeader & " not found in row 1 of " & .Name
                    Err.Clear
                    Exit For
                End If
            End With
        Next
    End If
Next

End Sub

 

[Shanaka Fernando]

thank you so much your support.