Solved: Macro to find code in many columns and copy findings (not easy)

[hunsnowboard]

Hi there Everyone! This is going to be a little bit tricky, but I hope I can explain my problem clearly and you will be able to help me.
The excel file is attached, however I altered every data because of privacy issues.

I have a big excel file with many data. In our case 6 columns will be important.
These 6 columns consists of 3 columns with codes and 3 columns with the corresponding names. I will focus on the codes columns for now (columns ?A?, ?AE? and ?BK?). The columns containing the codes are highlighted in red!

What I would like the macro to do is the following:

To search for the given code which is in worksheet(?List?).range(?B3?) in all of the highlighted code columns (columns ?A?, ?AE? and ?BK?, the ones that are highlighted with red.). In case there is a finding then copy the other the codes from the same row. (Example if I search for code: 100109 in column ?A? then copy all the codes from column ?AE? and ?BK? which are in the same rows with the findigs. Then search for 100109 in column ?AE? and copy the codes from column ?A? and ?BK? which are in the same rows with the findings. And then finally search for 100109 in column ?BK? and copy the codes from column ?A? and ?AE? which are in the same rows with the findings. And the paste these copied codes on the ?List? worksheet in the relevant columns. Example: if the code was copied from column ?A? then should be in column: Code_0, if copied from ?AE? then column: Code_1, if from ?BK? then column Code_2. If possible then the names of each code should be copied in the column next to the code column. (As you can see in worksheet ?List?).

I hope you can understand my problem, and you can help me! Thank you very much in advance! If you have any questions please do not hesitate to ask!

P.S.: In the real file the codes are 8 digit codes, and there are more than one sheets containing tables (so the macro should work for each worksheet, but that I think I can do it by myself).

Thank you!

[Bob Phillips]

Public Sub GetData()
Dim sh As Worksheet

With Worksheets("List")

With .Range("B7").Resize(.Rows.Count - 6, 6)

.ClearContents
.Interior.ColorIndex = xlColorIndexNone
.Font.ColorIndex = xlColorIndexAutomatic
End With
End With

With Worksheets("Sheet1")

Call CopyData(CheckRange:=.Columns("A"), _
CopyRange1Code:=.Range("AE2"), _
CopyRange1Name:=.Range("AJ2"), _
CopyRange2Code:=.Range("BK2"), _
CopyRange2Name:=.Range("BP2"), _
Target:=Worksheets("List").Range("B7"))
.Columns("A").AutoFilter

Call CopyData(CheckRange:=.Columns("AE"), _
CopyRange1Code:=.Range("A2"), _
CopyRange1Name:=.Range("D2"), _
CopyRange2Code:=.Range("BK2"), _
CopyRange2Name:=.Range("BP2"), _
Target:=Worksheets("List").Range("D7"))
.Columns("AE").AutoFilter

Call CopyData(CheckRange:=.Columns("BK"), _
CopyRange1Code:=.Range("A2"), _
CopyRange1Name:=.Range("D2"), _
CopyRange2Code:=.Range("AE2"), _
CopyRange2Name:=.Range("AJ2"), _
Target:=Worksheets("List").Range("F7"))
.Columns("AE").AutoFilter
End With
End Sub

Private Sub CopyData(ByRef CheckRange As Range, _
ByRef CopyRange1Code As Range, _
ByRef CopyRange1Name As Range, _
ByRef CopyRange2Code As Range, _
ByRef CopyRange2Name As Range, _
ByRef Target As Range)
Dim LastRow As Long
Dim rng As Range
Dim sh As Worksheet

Set sh = CheckRange.Parent
LastRow = sh.Cells(sh.Rows.Count, CheckRange.Column).End(xlUp).Row
CheckRange.AutoFilter field:=1, Criteria1:=Worksheets("List").Range("B3").Value
On Error Resume Next
Set rng = CopyRange1Code.Resize(LastRow - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then

rng.Copy Target
Set rng = CopyRange1Name.Resize(LastRow - 1).SpecialCells(xlCellTypeVisible)
rng.Copy Target.Offset(0, 1)

Set rng = CopyRange2Code.Resize(LastRow - 1).SpecialCells(xlCellTypeVisible)
rng.Copy Target.End(xlDown).Offset(1, 0)
Set rng = CopyRange2Name.Resize(LastRow - 1).SpecialCells(xlCellTypeVisible)
rng.Copy Target.Offset(0, 1).End(xlDown).Offset(1, 0)
End If
End Sub

[mdmackillop]

or
Option Explicit
Dim wsTgt As Worksheet
Dim wsSource As Worksheet


Sub SearchCols()
Dim SearchCols As Range
Dim ToFind As Range
Dim c As Range
Dim Rw As Long
Dim FirstAddress As String

Set wsTgt = Sheets("List")
Set wsSource = Sheets("Sheet1")
Set ToFind = wsTgt.Range("B3")
Rw = wsTgt.Cells(Rows.Count, 2).End(xlUp).Offset(1).Row


With wsSource
Set SearchCols = Union(.Columns(1), .Columns(31), .Columns(63))
With SearchCols
Set c = .Find(ToFind.Value, Lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
MoveData c, Rw
Rw = Rw + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

End With
End Sub

Sub MoveData(c As Range, Rw As Long)
With wsTgt
Select Case c.Column
Case 1
c.Copy .Cells(Rw, 2)
c.Offset(, 30).Copy .Cells(Rw, 4)
c.Offset(, 62).Copy .Cells(Rw, 6)
Case 31
c.Copy .Cells(Rw, 4)
c.Offset(, -30).Copy .Cells(Rw, 2)
c.Offset(, 32).Copy .Cells(Rw, 6)
Case 63
c.Copy .Cells(Rw, 6)
c.Offset(, -62).Copy .Cells(Rw, 2)
c.Offset(, -32).Copy .Cells(Rw, 4)
End Select
End With
End Sub

[hunsnowboard]

Hi Mdmackillop! I just can't thank you enough for your (previous and continous) help! :bow:
As about the code, I tried the second one (as it seemed to me that it works better). I have added a few new records on the second sheet ("Sheet2"), but the macro doesn't seem to search for those records. Am I doing something wrong? I posted the new version of the file with the new added records on the second sheet.

[lucas]

I just copied and pasted the searchcols routine back into itself, just above the end sub and changed the

Set wsSource = Sheets("Sheet1")

to sheet2 and it finds VIVI ok.


Part in red was copied and pasted back into the module and sheet1 changed to sheet2.......Malcolm or Bob will probably see an easier way...

Sub SearchCols()
Dim SearchCols As Range
Dim ToFind As Range
Dim c As Range
Dim Rw As Long
Dim FirstAddress As String

Set wsTgt = Sheets("List")
Set wsSource = Sheets("Sheet1")
Set ToFind = wsTgt.Range("B3")
Rw = wsTgt.Cells(Rows.Count, 2).End(xlUp).Offset(1).Row


With wsSource
Set SearchCols = Union(.Columns(1), .Columns(31), .Columns(63))
With SearchCols
Set c = .Find(ToFind.Value, Lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
MoveData c, Rw
Rw = Rw + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

End With

Set wsTgt = Sheets("List")
Set wsSource = Sheets("Sheet2")
Set ToFind = wsTgt.Range("B3")
Rw = wsTgt.Cells(Rows.Count, 2).End(xlUp).Offset(1).Row


With wsSource
Set SearchCols = Union(.Columns(1), .Columns(31), .Columns(63))
With SearchCols
Set c = .Find(ToFind.Value, Lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
MoveData c, Rw
Rw = Rw + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

End With
End Sub

[GTO]

Greetings to all,

Well shazzbutt! I started before Bob posted and figured I might as well finish (sleepless night)...

Anyways, not as neatly done, and I thought about scrapping it, but I tested. Maybe its just because of the cells being highlighted(?), but this seemed to process quicker.

This puts the names in as well, I think/hope the way you wanted. You'll probably have a better way of referring to the multiple sheets, but as the first example only had the one, I just made allowances by using Array().

Hope this helps,

Mark
Option Explicit
Sub AAA_IReallyNeedATypingClass()
Dim aSheetArray()
Dim intSheet As Integer
Dim rCell As Range
Dim sCell As String
Dim lRow_List As Long
Dim LROWS As Long
Dim wksList As Worksheet

'Dim sTime As Single
'sTime = Timer

LROWS = Rows.Count
Set wksList = Worksheets("List")
aSheetArray() = Array("Sheet1")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For intSheet = LBound(aSheetArray()) To UBound(aSheetArray())

With Worksheets(aSheetArray(intSheet))

With .Range(.Cells(2, 1), .Cells(LROWS, 1))
Set rCell = .Find(What:=wksList.Range("B3"), _
LookIn:=xlValues, _
Lookat:=xlWhole, _
SearchDirection:=xlNext)

If Not rCell Is Nothing Then
sCell = rCell.Address
Do
lRow_List = wksList.Cells(LROWS, 2).End(xlUp).Row
If wksList.Cells(LROWS, 3).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 3).End(xlUp).Row
If wksList.Cells(LROWS, 4).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 4).End(xlUp).Row
If wksList.Cells(LROWS, 5).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 5).End(xlUp).Row
If wksList.Cells(LROWS, 6).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 6).End(xlUp).Row
If wksList.Cells(LROWS, 7).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 7).End(xlUp).Row
lRow_List = lRow_List + 1

wksList.Range("B" & lRow_List).Value = rCell.Value
wksList.Range("D" & lRow_List).Value = rCell.Offset(, 30).Value
wksList.Range("F" & lRow_List).Value = rCell.Offset(, 62).Value

wksList.Range("C" & lRow_List).Value = rCell.Offset(, 3).Value
wksList.Range("E" & lRow_List).Value = rCell.Offset(, 35).Value
wksList.Range("G" & lRow_List).Value = rCell.Offset(, 67).Value

Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing _
And Not rCell.Address = sCell
End If
End With

With .Range(.Cells(2, 31), .Cells(LROWS, 31))

Set rCell = .Find(What:=Worksheets("List").Range("B3"), _
LookIn:=xlValues, _
Lookat:=xlWhole, _
SearchDirection:=xlNext)

If Not rCell Is Nothing Then
sCell = rCell.Address
Do
lRow_List = wksList.Cells(LROWS, 2).End(xlUp).Row
If wksList.Cells(LROWS, 3).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 3).End(xlUp).Row
If wksList.Cells(LROWS, 4).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 4).End(xlUp).Row
If wksList.Cells(LROWS, 5).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 5).End(xlUp).Row
If wksList.Cells(LROWS, 6).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 6).End(xlUp).Row
If wksList.Cells(LROWS, 7).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 7).End(xlUp).Row
lRow_List = lRow_List + 1

wksList.Range("B" & lRow_List).Value = rCell.Offset(, -30).Value
wksList.Range("D" & lRow_List).Value = rCell.Value
wksList.Range("F" & lRow_List).Value = rCell.Offset(, 32).Value

wksList.Range("C" & lRow_List).Value = rCell.Offset(, -27).Value
wksList.Range("E" & lRow_List).Value = rCell.Offset(, 5).Value
wksList.Range("G" & lRow_List).Value = rCell.Offset(, 37).Value

Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing _
And Not rCell.Address = sCell
End If
End With

With .Range(.Cells(2, 63), .Cells(LROWS, 63))

Set rCell = .Find(What:=Worksheets("List").Range("B3"), _
LookIn:=xlValues, _
Lookat:=xlWhole, _
SearchDirection:=xlNext)

If Not rCell Is Nothing Then
sCell = rCell.Address
Do
lRow_List = wksList.Cells(LROWS, 2).End(xlUp).Row
If wksList.Cells(LROWS, 3).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 3).End(xlUp).Row
If wksList.Cells(LROWS, 4).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 4).End(xlUp).Row
If wksList.Cells(LROWS, 5).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 5).End(xlUp).Row
If wksList.Cells(LROWS, 6).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 6).End(xlUp).Row
If wksList.Cells(LROWS, 7).End(xlUp).Row > lRow_List Then _
lRow_List = wksList.Cells(LROWS, 7).End(xlUp).Row
lRow_List = lRow_List + 1

wksList.Range("B" & lRow_List).Value = rCell.Offset(, -62).Value
wksList.Range("D" & lRow_List).Value = rCell.Offset(, -32).Value
wksList.Range("F" & lRow_List).Value = rCell.Value

wksList.Range("C" & lRow_List).Value = rCell.Offset(, -59).Value
wksList.Range("E" & lRow_List).Value = rCell.Offset(, -27).Value
wksList.Range("G" & lRow_List).Value = rCell.Offset(, 5).Value

Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing _
And Not rCell.Address = sCell
End If
End With
End With
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

'MsgBox Timer - sTime
End Sub

[mdmackillop]

I think the array of sheets is the way to go
Sub SearchCols()
Dim SearchCols As Range
Dim ToFind As Range
Dim c As Range
Dim Rw As Long
Dim FirstAddress As String
Dim arr, ws


arr = Array("Sheet1", "Sheet2", "Sheet3") '<== Change to suit

Set wsTgt = Sheets("List")
Set wsSource = Sheets("Sheet1")
Set ToFind = wsTgt.Range("B3")
Rw = wsTgt.Cells(Rows.Count, 2).End(xlUp).Offset(1).Row

For Each ws In arr
Set wsSource = Sheets(ws)

With wsSource
Set SearchCols = Union(.Columns(1), .Columns(31), .Columns(63))
With SearchCols
Set c = .Find(ToFind.Value, Lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
MoveData c, Rw
Rw = Rw + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

End With
Next
End Sub

[hunsnowboard]

Thank you for the code it is working brilliant! Thank you a lot for helping again! (Happy to see this site up and running again!)