Column Match

B

Buddy

Sub ColumnMatch()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim FoundOne As Range, LookInR As Range, LookForR As Range, c As Range
Dim nr3 As Long

Application.ScreenUpdating = False
Set ws1 = Sheets("R1")
Set ws2 = Sheets("R1")
Set ws3 = Sheets("R1")
Set LookInR = ws1.Range("A1").CurrentRegion
Set LookForR = Range(ws2.Range("A2"), ws2.Range("A" &
Rows.Count).End(xlUp))
nr3 = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each c In LookForR
With LookInR
Set FoundOne = .Find(What:=c, LookAt:=xlPart)
Do While Not FoundOne Is Nothing
FoundOne.EntireRow.Cut Destination:=ws3.Cells(nr3, 1)
nr3 = nr3 + 1
Set FoundOne = .FindNext
Loop
End With
Next c
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
Set LookInR = Nothing: Set LookForR = Nothing
Application.ScreenUpdating = True
End Sub


I am trying to adapt this code to perform the following functions but it’s
not going that well, any feedback so that I could get it to perform the steps
below would be helpful.

1. Go to Sheet “R1†look at the contents in cell A1 then look for a
duplicate of those contents in Column C and Column E.

2. When Column A has duplicates in Column C and Column E, copy that row of
Column A and include Column B, then copy the matching row in Column C while
including Column D, and finally copy the matching row of column Column E
while including the same row of Column F and Column G. In other words A:B
belong together, C:D belong together, and E:G belong together, but I want to
group these Columns together based on the contents in Columns A, C, and E.

3. Create a new worksheet and name it “Finalâ€

4. Select worksheet “Final†and paste Columns A:B, Columns C:D, and Columns
E:G from sheet “R1â€, which may have all been in all different rows, into the
same row in sheet “Finalâ€.

Go back to sheet “R1â€and repeat the same process for every row in Column A.
While including these two conditions
1. If Column A in sheet “R1†does not have a match in Column C and Column E
then leave it alone.
2. If Column A sheet “R1†has more than one match in Column C and Column E,
copy only the rows in Columns C:D, and Columns E:G where the duplicates
exist. Select sheet “Final†and underneath the 1st time the matching
contents were pasted in C:D and E:G paste the duplicates. After all the
duplicates have been pasted protect the same rows in Columns A:B so that no
more data can be pasted into them.
 
J

joel

Try this

Sub ColumnMatch()

Application.ScreenUpdating = False
NewRow = 1
Set ws1 = Sheets("R1")
With ws1
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
A_Data = .Range("A" & RowCount)
B_Data = .Range("B" & RowCount)
FirstNewRow = NewRow
Set c1 = .Columns("C").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c1 Is Nothing Then
firstAddr = c.Address
Do
C_Data = .Range("C" & RowCount)
D_Data = .Range("D" & RowCount)
With Sheets("Final")
.Range("A" & NewRow) = A_Data
.Range("B" & NewRow) = B_Data
.Range("C" & NewRow) = C_Data
.Range("D" & NewRow) = D_Data
NewRow = NewRow + 1
End With
Set c = .Columns("C").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Set c1 = .Columns("E").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c1 Is Nothing Then
firstAddr = c.Address
Do
E_Data = .Range("E" & RowCount)
F_Data = .Range("F" & RowCount)
G_Data = .Range("G" & RowCount)
With Sheets("Final")
If FirstNewRow > RowCount Then
.Range("A" & FirstNewRow) = A_Data
.Range("B" & FirstNewRow) = B_Data
End If
.Range("E" & FirstNewRow) = E_Data
.Range("F" & FirstNewRow) = F_Data
.Range("G" & FirstNewRow) = G_Data
FirstNewRow = FirstNewRow + 1
End With
Set c = .Columns("E").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Next RowCount
End With
Application.ScreenUpdating = True
End Sub
 
B

Buddy

The macro seems to be getting stuck on this part of the macro

firstAddr = c.Address
 
J

joel

Istarted to use C1 and then changed to using just C. I forgot to change some
of the C1 code.

Sub ColumnMatch()

Application.ScreenUpdating = False
NewRow = 1
Set ws1 = Sheets("R1")
With ws1
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
A_Data = .Range("A" & RowCount)
B_Data = .Range("B" & RowCount)
FirstNewRow = NewRow
Set c = .Columns("C").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
C_Data = .Range("C" & RowCount)
D_Data = .Range("D" & RowCount)
With Sheets("Final")
.Range("A" & NewRow) = A_Data
.Range("B" & NewRow) = B_Data
.Range("C" & NewRow) = C_Data
.Range("D" & NewRow) = D_Data
NewRow = NewRow + 1
End With
Set c = .Columns("C").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Set c = .Columns("E").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
E_Data = .Range("E" & RowCount)
F_Data = .Range("F" & RowCount)
G_Data = .Range("G" & RowCount)
With Sheets("Final")
If FirstNewRow > RowCount Then
.Range("A" & FirstNewRow) = A_Data
.Range("B" & FirstNewRow) = B_Data
End If
.Range("E" & FirstNewRow) = E_Data
.Range("F" & FirstNewRow) = F_Data
.Range("G" & FirstNewRow) = G_Data
FirstNewRow = FirstNewRow + 1
End With
Set c = .Columns("E").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Next RowCount
End With
Application.ScreenUpdating = True
End Sub
 
B

Buddy

It's getting some of the them and not others, but the assitance is very much
appreciated. If your still interested.

Here is a condensed version of what I have. Normally there would be many
more rows.

Column A Column B Column C Column D Column E Column F Column G
66076 1 67055 2 67055 Part A 2
66104 1 72064 1 72064 Part G 1
66108 1 74092 2 S100 Part Y 3
74092 1 74093 S100 Part C 1
67032 67059 74092 Part J 2
67055 1 67060 6 1530 Part T 1
67059 1 S100 3 1530 Part Q 2
72064 1 1170 66108 Part U 1
74039 66076 12 66076 Part X 2

Here is a condensed version of what I am trying to get to. (Normally there
would be many more rows)

Column A Column B Column C Column D Column E Column F Column G
66076 1 66076 12 66076 Part X 2
74092 1 74092 2 74092 Part J 2
67055 1 67055 2 67055 Part A 2
 
J

joel

I used the wrong item to point to the data that was copied from sheet R1. I
nered to put c.row in 5 places to represent the row where daa was found in
columns C & E.

Sub ColumnMatch()

Application.ScreenUpdating = False
NewRow = 1
Set ws1 = Sheets("R1")
With ws1
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
A_Data = .Range("A" & RowCount)
B_Data = .Range("B" & RowCount)
FirstNewRow = NewRow
Set c = .Columns("C").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
C_Data = .Range("C" & c.Row)
D_Data = .Range("D" & c.Row)
With Sheets("Final")
.Range("A" & NewRow) = A_Data
.Range("B" & NewRow) = B_Data
.Range("C" & NewRow) = C_Data
.Range("D" & NewRow) = D_Data
NewRow = NewRow + 1
End With
Set c = .Columns("C").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Set c = .Columns("E").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
E_Data = .Range("E" & c.Row)
F_Data = .Range("F" & c.Row)
G_Data = .Range("G" & c.Row)
With Sheets("Final")
If FirstNewRow > RowCount Then
.Range("A" & FirstNewRow) = A_Data
.Range("B" & FirstNewRow) = B_Data
End If
.Range("E" & FirstNewRow) = E_Data
.Range("F" & FirstNewRow) = F_Data
.Range("G" & FirstNewRow) = G_Data
FirstNewRow = FirstNewRow + 1
End With
Set c = .Columns("E").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Next RowCount
End With
Application.ScreenUpdating = True
End Sub
 
B

Buddy

This macro is freak’in rocking. I have a situation that’s come up. Is there
a way to get to this

66076 1 66076 12 66076 Part X 2
74092 1 74092 2 74092 Part J 2
74092 Part J2 1
74092 Part J3 3
67055 1 67055 2 67055 Part A 2

When I have these circumstances occurring…

66076 1 67055 2 67055 Part A 2
66104 1 72064 1 72064 Part G 1
66108 1 74092 2 S100 Part Y 3
74092 1 74093 S100 Part C 1
67032 67059 74092 Part J 2
67055 1 67060 6 1530 Part T 1
69999 S200 1 74092 Part J2 1
67059 1 S100 3 1530 Part Q 2
72064 1 1170 66108 Part U 1
70119 S300 74092 PartJ3 3
74039 66076 12 66076 Part X 2

And I’ve not yet figured out how on my own.
 
J

joel

My design considered the case you were looking for but I had a couple of
small errors that I didn't catch in my original testing. This should work

Sub ColumnMatch()

Application.ScreenUpdating = False
Newrow = 1
Set ws1 = Sheets("R1")
With ws1
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
A_Data = .Range("A" & RowCount)
B_Data = .Range("B" & RowCount)
FirstNewRow = Newrow
Set c = .Columns("C").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
C_Data = .Range("C" & c.Row)
D_Data = .Range("D" & c.Row)
With Sheets("Final")
.Range("A" & Newrow) = A_Data
.Range("B" & Newrow) = B_Data
.Range("C" & Newrow) = C_Data
.Range("D" & Newrow) = D_Data
Newrow = Newrow + 1
End With
Set c = .Columns("C").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Set c = .Columns("E").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
E_Data = .Range("E" & c.Row)
F_Data = .Range("F" & c.Row)
G_Data = .Range("G" & c.Row)
With Sheets("Final")
If FirstNewRow >= Newrow Then
.Range("A" & FirstNewRow) = A_Data
.Range("B" & FirstNewRow) = B_Data
End If
.Range("E" & FirstNewRow) = E_Data
.Range("F" & FirstNewRow) = F_Data
.Range("G" & FirstNewRow) = G_Data
FirstNewRow = FirstNewRow + 1
End With
Set c = .Columns("E").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
If FirstNewRow > Newrow Then
Newrow = FirstNewRow
End If
End If

Next RowCount
End With
Application.ScreenUpdating = True
End Sub
 
B

Buddy

You are the man! It works. Thank you.

joel said:
My design considered the case you were looking for but I had a couple of
small errors that I didn't catch in my original testing. This should work

Sub ColumnMatch()

Application.ScreenUpdating = False
Newrow = 1
Set ws1 = Sheets("R1")
With ws1
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
A_Data = .Range("A" & RowCount)
B_Data = .Range("B" & RowCount)
FirstNewRow = Newrow
Set c = .Columns("C").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
C_Data = .Range("C" & c.Row)
D_Data = .Range("D" & c.Row)
With Sheets("Final")
.Range("A" & Newrow) = A_Data
.Range("B" & Newrow) = B_Data
.Range("C" & Newrow) = C_Data
.Range("D" & Newrow) = D_Data
Newrow = Newrow + 1
End With
Set c = .Columns("C").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
End If

Set c = .Columns("E").Find(what:=A_Data, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddr = c.Address
Do
E_Data = .Range("E" & c.Row)
F_Data = .Range("F" & c.Row)
G_Data = .Range("G" & c.Row)
With Sheets("Final")
If FirstNewRow >= Newrow Then
.Range("A" & FirstNewRow) = A_Data
.Range("B" & FirstNewRow) = B_Data
End If
.Range("E" & FirstNewRow) = E_Data
.Range("F" & FirstNewRow) = F_Data
.Range("G" & FirstNewRow) = G_Data
FirstNewRow = FirstNewRow + 1
End With
Set c = .Columns("E").FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstAddr
If FirstNewRow > Newrow Then
Newrow = FirstNewRow
End If
End If

Next RowCount
End With
Application.ScreenUpdating = True
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top