Copy Data from one Sheet to another(find string and copy all Rows and Columns until Empty)

[silentwolf]

Hi guys,

I would need some help please.

I like to find a particular string within a worksheet and copy all cells below and to the right of that cell to another worksheet but only till the row or column is empty.

So pasically find Art:Nr: and copy all data below and to the right until the row or column is empty and then find the next Art:Nr: and do the same...

Can someone help me with this issue please?

Art:Nr	VPE	Einheit	Price
1252	10	l	12,99

 

[silentwolf]

Hi again,

this code I got so far it is not quite working yet...
Was wondering if someone can give me a little help to complete this code..

Sub TestCopy()
    Application.ScreenUpdating = False
    Dim i As Long
    
    Dim ans As String
    ans = "Art.-Nr."
    
    Dim Lastrow As Long
    Dim Lastrowb As Long
    Lastrow = Sheets("Abby_ScanN").Cells(Rows.Count, "A").End(xlUp).Row
    Lastrowb = Sheets("NewSheet").Cells(Rows.Count, "A").End(xlUp).Row + 1
    Sheets("Abby_ScanN").Activate
        For i = 1 To Lastrow
            If InStr(Sheets("Abby_ScanN").Cells(i, "A").Value, ans) Then
'                Debug.Print Cells(i, "A").Address
                Cells(i, "A").CurrentRegion.Copy Destination:=Sheets("NewSheet").Rows(Lastrowb)
                Lastrowb = Lastrowb + 1
            End If
        Next
    Application.ScreenUpdating = True
End Sub

How does this code need to change so it it findes again the last used row in column A from Lastrowb? Currently it override the values already paste into the NewSheet.

Thanks for your help!

Much appreciated..

 

[Fluff]

How about

            If InStr(Sheets("Abby_ScanN").Cells(i, "A").Value, Ans) Then
'                Debug.Print Cells(i, "A").Address
                With Cells(i, "A").CurrentRegion
                     .Copy destination:=Sheets("NewSheet").Rows(Lastrowb)
                     Lastrowb = Lastrowb + .Rows.Count
                End With
            End If

 

[silentwolf]

How about

            If InStr(Sheets("Abby_ScanN").Cells(i, "A").Value, Ans) Then
'                Debug.Print Cells(i, "A").Address
                With Cells(i, "A").CurrentRegion
                     .Copy destination:=Sheets("NewSheet").Rows(Lastrowb)
                     Lastrowb = Lastrowb + .Rows.Count
                End With
            End If

Hi Fluff,

thank you for your help!
It is getting closer..
Two questions what if I like to exact word?
And also at the moment it copies some date accross the hole NewSheet...

Somewhere is still a problem but I can not figure it out unfortunatelly where the issue is...

Thank you!!

 

[Fluff]

If you want an exact match use

If Sheets("Abby_ScanN").Cells(i, "A").Value = Ans Then

 

[silentwolf]

Thank you very much Fluff.
Copy is still not quite working but I will look into it more...

Cheers

 

[Fluff]

Glad to help & thanks for the feedback.