Loop through Column on one Sheet and Paste to Row from another sheet

wtom0412

Board Regular
Joined
Jan 3, 2015
Messages
180
Office Version
  1. 365
Platform
  1. Windows
Hello All,

I have got a bit of code that looks into Column A on Sheet3, finds a match, then Offset copies a value from Sheet8 to the matched row in Sheet3.

This works really well for the first time it finds a match, but what I can't figure out is how to get it to continue to move down the column to look for the next matched cell (as will be immediately obvious to you guru's)

I have a loop in the following code which obviously doesn't work, and that's the part I'm stuck on. Here's what I have so far...

VBA Code:
Sub Paste_Inci()

Dim i As Integer
Dim finalrow As Integer

FindItem = Sheet8.Range("D1").Value 'The sheet that contains the the match value

On Error Resume Next
FoundItem = Sheet3.Range("A2:A65535").Find(What:=FindItem).Address 'This is the sheet where the data will be pasted
On Error GoTo 0

finalrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = 1 To finalrow

If FoundItem <> "" Then
    PasteLocation = Sheet3.Range(FoundItem).Offset(0, 16).Address 'The column where the data will be pasted
    Sheet8.Range("G1").Copy Sheet3.Range(PasteLocation) 

Else
        MsgBox ("Item not found. No action performed.")
End If

i = i + 1

Next i


End Sub

I just can't think where to put the logic to get it to continue to look down the column, find the next match and paste (BTW, the same data will be pasted each time it finds a match).

Any assistance would be greatly appreciated.

Cheers, Toby
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
See if this does what you want. Note: must be run when the worksheet with code name Sheet3 is the active sheet.
VBA Code:
Sub Paste_Inci()
Dim finalrow As Long, FoundItem As Range, FindItem, fAdr As String
FindItem = Sheet8.Range("D1").Value 'The sheet that contains the the match value
On Error Resume Next
Set FoundItem = Sheet3.Range("A:A").Find(What:=FindItem) 'This is the sheet where the data will be pasted
Application.ScreenUpdating = False
On Error GoTo 0
If Not FoundItem Is Nothing Then
    fAdr = FoundItem.Address
    Do
        Sheet8.Range("G1").Copy FoundItem.Offset(0, 16)
        Set FoundItem = Sheet3.Range("A:A").FindNext(FoundItem)
        If FoundItem Is Nothing Then Exit Do
        If FoundItem.Address = fAdr Then Exit Do
    Loop
Else
    MsgBox ("Item not found. No action performed.")
End If
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thank you JoeMo, that works perfectly!! I was kinda close, but there's no way I could have resolved it like that.

I do now have one slight problem. I have written a whole bunch of other macros (six in total) that need to run before we get to this code. When I try to Call Paste_Inci, from the sixth Macro, it tells me Sub or Function not defined. All of the other code is in a Module.

In the process of running these 7 Macros, I don't need to go to Sheet3 at all, I call the whole routine from Sheet2 and stay there.

Is there any way I can call this code from a Module?

Cheers, Toby
 
Upvote 0
Thank you JoeMo, that works perfectly!! I was kinda close, but there's no way I could have resolved it like that.

I do now have one slight problem. I have written a whole bunch of other macros (six in total) that need to run before we get to this code. When I try to Call Paste_Inci, from the sixth Macro, it tells me Sub or Function not defined. All of the other code is in a Module.

In the process of running these 7 Macros, I don't need to go to Sheet3 at all, I call the whole routine from Sheet2 and stay there.

Is there any way I can call this code from a Module?

Cheers, Toby
You are welcome.
Are all 7 macros in the same module/same workbook?
 
Upvote 0
Yes, one Module, same Workbook.
If that's a standard module (not a worksheet module), are you sure the call has the correct spelling of the module (no leading or trailing spaces)?
Really hard to diagnose w/o seeing the entire module.
 
Upvote 0
Standard Module (Modules/Module1 - not a Class Module). Spelling is correct, I always copy and paste from the Sub name, but I did check that also?
 
Upvote 0
Standard Module (Modules/Module1 - not a Class Module). Spelling is correct, I always copy and paste from the Sub name, but I did check that also?
Can you post the module?
 
Upvote 0
VBA Code:
Sub Get_formula()

Dim fromdata As Worksheet
Dim todata As Worksheet
Dim formula As String
Dim finalrow As Integer
Dim i As Integer

Set fromdata = Sheet2
Set todata = Sheet8

formula = fromdata.Range("R1")

todata.Range("A:J").ClearContents

fromdata.Select
finalrow = Cells(Rows.Count, 3).End(xlUp).Row

For i = 1 To finalrow
    If Cells(i, 3) = formula Then
        Range(Cells(i, 5), Cells(i, 6)).Copy
        todata.Select
        Sheet8.Range("A50").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        fromdata.Select
        End If
        

Next i

Sheet8.Activate

Call Sort_INCI

End Sub



Sub Sort_INCI()

Sheet8.Activate

ActiveSheet.Range("A1").Value = "Ingredient"
ActiveSheet.Range("B1").Value = "Percentage"
ActiveSheet.Range("C1").Value = "INCI"
ActiveSheet.Range("D1").Select

ActiveCell.Value = Sheet2.Range("R1").Value


    Range("A1").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("INCI List").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("INCI List").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("B1:B50"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("INCI List").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("INCI List").AutoFilter.Sort.SortFields.Clear
    Selection.AutoFilter

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

Call Get_INCI


End Sub

Sub Get_INCI()

Dim finalrow As Integer
Dim i As Integer
Dim j As Integer
Dim lookup_value As String
Dim table_array As Range

Sheet8.Range("C2").Activate

finalrow = Cells(Rows.Count, 2).End(xlUp).Row

Set table_array = Worksheets("Ingredients").Range("B:E")

ActiveCell.Value = "=VLOOKUP(A2,Ingredients!$B:$E,4,0)"

For i = 1 To finalrow

    If ActiveCell.Offset(1, -1) = "" Then

        If Sheet3.Range("T1").Value = 1 Then

            Sheet3.Range("T1").Value = ""
    
''            Exit Sub
    
        Else
    
            Call Create_INCI
    
        End If
    
    Else
    
    ActiveCell.Offset(1, 0).Select
    
    lookup_value = ActiveCell.Offset(0, -2).Value
    
    ActiveCell = Application.WorksheetFunction.VLookup(lookup_value, table_array, 4, False)

End If

Next



    
End Sub

Sub Create_INCI()
    
    Dim answer As Integer



    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


Sheet8.Range("F1").Activate

    
Range("C2").End(xlDown).Select
For j = 2 To ActiveCell.Row
    Range("C" & j).Select
    strString = strString & ", " & Selection
Next j

Range("E1").Activate

ActiveCell.Value = strString

    Columns("A:E").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
ActiveSheet.Range("F1").Value = "=RemoveFirstC(E1,2)"
    
    Range("F1").Select
    Selection.Copy
    Range("G1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


    
    Range("Q27").Select
    
        With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .CutCopyMode = False
        
    End With
    
    
'If Range("M47") <> "1" Then
'
'    answer = MsgBox("Please confirm you qwish to post the INCI agains the Product", vbQuestion + vbYesNo + vbDefaultButton2, "Please confirm")
'
'If answer = vbNo Then
'  Exit Sub
'
'Else

Sheet3.Activate

Range("T1").Value = "1"


    
'Call Paste_Inci

'End If
'End If


End Sub



Public Function RemoveFirstC(rng As String, cnt As Long)
 
RemoveFirstC = Right(rng, Len(rng) - cnt)
 
End Function



Sub Create_INCI_List()

MsgBox "Please close this box and then DOUBLE CLICK on the product name you want to Create / Update"


End Sub
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,947
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top