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

[wtom0412]

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...

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

 

[wtom0412]

This is on Sheet2 Module

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect(Target, Columns("C")) Is Nothing Then
    Cancel = True
    If Target.Row > 1 And Len(Target.Value) Then Worksheets("Formulas").Range("R1").Value = Target.Value

  End If
End Sub

 

[wtom0412]

This is on Sh

'
'
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

'

eet3 Module

 

[JoeMo]

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

This is on Sh

'
'
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

'

eet3 Module

Why is it on a sheet module? I thought you said all 7 macros are in a standard module? Try moving it to the module you posted in post #9.

 

[wtom0412]

The Call that fails is in Sub Create_INCI. I have done a bit of a work around by opening Book3, and then running the code from a button on the sheet.

 

[wtom0412]

Sorry, I may have misinterpreted your instruction when you first posted the code?

Note: must be run when the worksheet with code name Sheet3 is the active sheet.

 

[wtom0412]

When I first read that, I assumed you meant to put it on the Sheet Module?

 

[wtom0412]

I see it now. So I can just Activate Sheet3, run this portion of the code, then return back to Sheet2 all behind ScreenUpdate?

 

[JoeMo]

I see it now. So I can just Activate Sheet3, run this portion of the code, then return back to Sheet2 all behind ScreenUpdate?

If it's standard code there's no reason to put it in a sheet module. If you put it with the calling routine in the standard module you told me it was in to begin with, that should enable the call.

 

[wtom0412]

Thanks JoeMo, all good now, it works perfectly, thanks for your help.

 

[JoeMo]

Thanks JoeMo, all good now, it works perfectly, thanks for your help.

You are welcome - thanks for the reply.