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

wtom0412

Board Regular
Joined
Jan 3, 2015
Messages
168
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
 

wtom0412

Board Regular
Joined
Jan 3, 2015
Messages
168
This is on Sheet2 Module
Code:
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
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

wtom0412

Board Regular
Joined
Jan 3, 2015
Messages
168
This is on Sh
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

'
eet3 Module
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,410
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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
This is on Sh
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

'
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

Board Regular
Joined
Jan 3, 2015
Messages
168
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

Board Regular
Joined
Jan 3, 2015
Messages
168

ADVERTISEMENT

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

Board Regular
Joined
Jan 3, 2015
Messages
168

ADVERTISEMENT

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

MrExcel MVP
Joined
May 26, 2009
Messages
17,410
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,126,998
Messages
5,622,096
Members
415,876
Latest member
csibonga2k17

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
Top