Column Match
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 R1and 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.
|