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

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




"Buddy" wrote:

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

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

firstAddr = c.Address


"joel" wrote:

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




"Buddy" wrote:

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

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




"Buddy" wrote:

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

firstAddr = c.Address


"joel" wrote:

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




"Buddy" wrote:

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

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



"joel" wrote:

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




"Buddy" wrote:

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

firstAddr = c.Address


"joel" wrote:

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




"Buddy" wrote:

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

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




"Buddy" wrote:

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



"joel" wrote:

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




"Buddy" wrote:

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

firstAddr = c.Address


"joel" wrote:

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




"Buddy" wrote:

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

This macro is freakin rocking. I have a situation thats 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 Ive not yet figured out how on my own.


"joel" wrote:

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




"Buddy" wrote:

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



"joel" wrote:

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




"Buddy" wrote:

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

firstAddr = c.Address


"joel" wrote:

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




"Buddy" wrote:

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

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





"Buddy" wrote:

This macro is freakin rocking. I have a situation thats 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 Ive not yet figured out how on my own.


"joel" wrote:

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




"Buddy" wrote:

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



"joel" wrote:

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




"Buddy" wrote:

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

firstAddr = c.Address


"joel" wrote:

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




"Buddy" wrote:

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

You are the man! It works. Thank you.

"joel" wrote:

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





"Buddy" wrote:

This macro is freakin rocking. I have a situation thats 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 Ive not yet figured out how on my own.


"joel" wrote:

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




"Buddy" wrote:

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



"joel" wrote:

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




"Buddy" wrote:

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

firstAddr = c.Address


"joel" wrote:

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)