VBA - Searching for repeat values, copying, pasting, & looping

[Pineapple_Crazy]

Hey Everyone,

Got a question I'm hoping to get some help on. Below I have copied a small bit of my code. What I'm trying to do is search out a value from a msg box insertion (called "myValue"), find another value (called "Added:"), and copy the adjacent cell values between "myValue" and "Added:" into another worksheet (where I do this is shown bold in the code below). However, what the user enters into the msg box can be found in the spreadsheet many times. I'm trying to figure out a way to loop through the spreadsheet so that I can copy adjacent values for ever instance "myValue" and "Added:" are found. Anything I have tried is not working or simply copies the same set over and over again. Can someone provide some advice? Thanks much!

Sub FindValues()

Dim findrow As Long, findrow2 As Long
Dim find As Range
Dim StrFile As String
Dim StrPath As String
 
StrPath = "Y:\Finance\BI\Pete\Pete Documents\Misc\"
StrFile = Dir(StrPath & "Vendor*" & "*.xls*")

'msg box to enter vendor ID


myValue = InputBox("Please Enter the Vendor Name", "VENDOR NAME", "AMES001")


'Opens file
Workbooks.Open Filename:=StrPath & StrFile


'Finding values

[B]findrow = Range("A:A").find([/B]myValue[B], Range("A1")).Row[/B]
[B]findrow2 = Range("A:A").find([/B][SIZE=2]"Added:"[/SIZE][B], Range("A" & findrow)).Row[/B]
[B]Range("A" & findrow + 0 & ":A" & findrow2 + 0).Offset(0, 1).Copy[/B]


'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.


Windows("FinalReport_Vendor.xlsm").Activate
Sheets("Data").Activate
ActiveSheet.Range("B5000").End(xlUp).Offset(1, 0).Select
'ActiveSheet.Paste
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True


End Sub

 

[tonyyy]

Pineapple_Crazy,

You might consider the following...

Sub FindValues()

Dim findrow As Long, findrow2 As Long
Dim find As Range
Dim StrFile As String
Dim StrPath As String
Dim r1 As Long, wb As Workbook
 
StrPath = "Y:\Finance\BI\Pete\Pete Documents\Misc\"
StrFile = Dir(StrPath & "Vendor*" & "*.xls*")

'msg box to enter vendor ID
myValue = InputBox("Please Enter the Vendor Name", "VENDOR NAME", "AMES001")

'Opens file
Set wb = Workbooks.Open(Filename:=StrPath & StrFile)

'Finding values
findrow = Range("A:A").find(myValue, Range("A1")).Row
findrow2 = Range("A:A").find("Added:", Range("A" & findrow)).Row
Range("A" & findrow + 0 & ":A" & findrow2 + 0).Offset(0, 1).Copy
r1 = findrow

'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.
Windows("FinalReport_Vendor.xlsm").Activate
Sheets("Data").Activate
ActiveSheet.Range("B5000").End(xlUp).Offset(1, 0).Select
'ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

'Find and copy/paste additional values
Do
    wb.Activate
    findrow = Range("A:A").find(what:=myValue, after:=Cells(findrow, 1)).Row
    findrow2 = Range("A:A").find(what:="Added:", after:=Range("A" & findrow)).Row
    Range("A" & findrow + 0 & ":A" & findrow2 + 0).Offset(0, 1).Copy

    'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.
    Windows("FinalReport_Vendor.xlsm").Activate
    Sheets("Data").Activate
    ActiveSheet.Range("B5000").End(xlUp).Offset(1, 0).Select
    'ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=True
Loop While findrow > 1 And findrow <> r1
End Sub

Please note the code is untested.

Cheers,

tonyyy

 

[Pineapple_Crazy]

Pineapple_Crazy,

You might consider the following...

Sub FindValues()

Dim findrow As Long, findrow2 As Long
Dim find As Range
Dim StrFile As String
Dim StrPath As String
Dim r1 As Long, wb As Workbook
 
StrPath = "Y:\Finance\BI\Pete\Pete Documents\Misc\"
StrFile = Dir(StrPath & "Vendor*" & "*.xls*")

'msg box to enter vendor ID
myValue = InputBox("Please Enter the Vendor Name", "VENDOR NAME", "AMES001")

'Opens file
Set wb = Workbooks.Open(Filename:=StrPath & StrFile)

'Finding values
findrow = Range("A:A").find(myValue, Range("A1")).Row
findrow2 = Range("A:A").find("Added:", Range("A" & findrow)).Row
Range("A" & findrow + 0 & ":A" & findrow2 + 0).Offset(0, 1).Copy
r1 = findrow

'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.
Windows("FinalReport_Vendor.xlsm").Activate
Sheets("Data").Activate
ActiveSheet.Range("B5000").End(xlUp).Offset(1, 0).Select
'ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

'Find and copy/paste additional values
Do
    wb.Activate
    findrow = Range("A:A").find(what:=myValue, after:=Cells(findrow, 1)).Row
    findrow2 = Range("A:A").find(what:="Added:", after:=Range("A" & findrow)).Row
    Range("A" & findrow + 0 & ":A" & findrow2 + 0).Offset(0, 1).Copy

    'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.
    Windows("FinalReport_Vendor.xlsm").Activate
    Sheets("Data").Activate
    ActiveSheet.Range("B5000").End(xlUp).Offset(1, 0).Select
    'ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=True
Loop While findrow > 1 And findrow <> r1
End Sub

Please note the code is untested.

Cheers,

tonyyy

Hi tonyyy,

Thanks so much! Made just a slight adjustment and works beautifully! Really appreciate it.

Code:

Sub FindValues()

Dim findrow As Long, findrow2 As Long
Dim find As Range
Dim StrFile As String
Dim StrPath As String
Dim r1 As Long, wb As Workbook
 
StrPath = "Y:\Finance\BI\Pete\Pete Documents\Misc\"
StrFile = Dir(StrPath & "Vendor*" & "*.xls*")


'msg box to enter vendor ID
myValue = InputBox("Please Enter the Vendor Name", "VENDOR NAME", "AMES001")


'Opens file
Set wb = Workbooks.Open(Filename:=StrPath & StrFile)


'Finding values
findrow = Range("A:A").find(myValue, Range("A1")).Row
findrow2 = Range("A:A").find("Added:", Range("A" & findrow)).Row
Range("A" & findrow + 0 & ":A" & findrow2 + 0).Offset(0, 1).Copy
r1 = findrow


Do
    wb.Activate
    findrow = Range("A:A").find(what:=myValue, after:=Cells(findrow, 1)).Row
    findrow2 = Range("A:A").find(what:="Added:", after:=Range("A" & findrow)).Row
    Range("A" & findrow + 0 & ":A" & findrow2 + 0).Offset(0, 1).Copy


    'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.
    Windows("FinalReport_Vendor.xlsm").Activate
    Sheets("Data").Activate
    ActiveSheet.Range("B5000").End(xlUp).Offset(1, 0).Select
    'ActiveSheet.Paste
    Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=True
Loop While findrow > 1 And findrow <> r1
End Sub

 

[tonyyy]

Thanks so much! Made just a slight adjustment and works beautifully!

You're very welcome.

Question: With the "slight adjustment" - Is the code copying/pasting data from the first findrow? (I suspect not.)

 

[Pineapple_Crazy]

You're very welcome.

Question: With the "slight adjustment" - Is the code copying/pasting data from the first findrow? (I suspect not.)

Hey tonyyy,

Yes, you are indeed correct. I removed the first paste and it works great! Otherwise it was copying/pasting and essentially duplicating a row.

Thanks again.