I need to compare 1 worksheet (Sheet1) to another similar worksheet (Sheet2)
Sheet2 contains up to date information,which needs to be transferred to Sheet1.
However, I've run into a couple of problems:
There are some rows in Sheet1 that are not Sheet2. These need to be ignored/skipped over
There are some rows in Sheet2 that are not Sheet1. These need to be appended to the end of Sheet1
If a row exists in both Sheets, the information from the row sheet 2 needs to be transferred to the corresponding row in Sheet1
For what its worth, they have same number of columns and the column titles are exactly the same.
I've tried using a dictionary object to accomplish this but am still having all sorts of trouble.
Here's the code I have tried thus far:
Sub createDictionary()
Dim dict1, dict2 As Object
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Dim maxRows1, maxRows2 As Long
Dim i, ii, j, k As Integer
maxRows1 = Worksheets("Sheet1").Range("A65000").End(xlUp).Row
For i = 2 To maxRows1
Dim cell1 As String
cell1 = Worksheets("Sheet1").cells(i, 2).Text & " " & Worksheets("Sheet1").cells(i, 11).Text
If Not dict1.Exists(cell1) Then
dict1.Add cell1, cell1
End If
Next i
maxRows2 = Worksheets("Sheet2").Range("A65000").End(xlUp).Row
For ii = 2 To maxRows2
Dim cell2 As String
cell2 = Worksheets("Sheet2").cells(ii, 11).Text
If Not dict2.Exists(cell2) Then
dict2.Add cell2, cell2
End If
Next ii
Dim rngSearch1, rngFound1, rngSearch2, rngFound2 As Range
For j = 2 To maxRows1
Dim Sheet1Str, Sheet2Str As String
Sheet1Str = Worksheets("Sheet1").cells(j, 2).Text & " " & Worksheets("Sheet1").cells(j, 11).Text
Sheet2Str = Worksheets("Sheet2").cells(j, 11).Text
If dict2.Exists(Sheet1Str) = False Then
'ElseIf Not dict1.Exists(Sheet2) Then
'
' Worksheets("Sheet2").Range("A" & j & ":" & "Z" & j).Copy
' Worksheets("Sheet1").Range("A" & maxRows1 + 1).Insert
' Worksheets("Sheet1").Range("A" & maxRows1 + 1).Interior.Color = RGB(255, 255, 0)
' Worksheets("Sheet1").Range("U" & maxRows1 + 1) = "INCH"
' Worksheets("Sheet1").Range("Q" & maxRows1 + 1) = "FPM"
' Worksheets("Sheet1").Range("S" & maxRows1 + 1) = "INCHES WIDE"
' Worksheets("Sheet2").Range("K" & j) = Replace(Worksheets("Sheet2").Range("K" & j), Worksheets("Sheet2").Range("B" & j), "")
' Worksheets("Sheet1").Range("K" & maxRows1 + 1) = Trim(Worksheets("Sheet2").Range("K" & j))
Else
For k = 3 To 6
If Not k = 11 Then
If Not UCase(Worksheets("Sheet1").cells(j, k).Value) = UCase(Worksheets("Sheet2").cells(j, k).Value) Then
Worksheets("Sheet1").cells(j, k).Value = Worksheets("Sheet2").cells(j, k).Value
End If
End If
Next k
End If
Next j
End Sub
Cool question, and the "does row order matter" question above lends itself nicely to using Excel's built in Range.RemoveDuplicates method. Let's get into it...
Suppose Sheet1 looks like this:
Let's say Sheet2 looks like this:
All the conditions that are described in your original question are met here. Namely:
There are rows on Sheet1 that are not on Sheet2 (row 2, for example). These will be left alone.
There are rows on Sheet2 that are not on Sheet1 (row 2, for example). These will be added to Sheet1.
There are rows that are the same on Sheet2 and Sheet1, save for a single update. (Row 7 on Sheet2, for example.) These rows will be updated on Sheet1. Of course, your situation will be different -- perhaps more columns might be updated, or they might not be in column E like my example -- you'll need to do a bit of customization here.
The following heavily-commented script walks through copying data from Sheet2 to Sheet1, then letting Excel's built-in Range.RemoveDuplicates method kill all of the rows that have been updated in column E. The script also makes use of a couple handy functions: LastRowNum and LastColNum.
Option Explicit
Sub MergeSheetTwoIntoSheetOne()
Dim Range1 As Range, Range2 As Range
Dim LastRow1 As Long, LastRow2 As Long, _
LastCol As Long
'setup - set references up-front
LastRow2 = LastRowNum(Sheet2)
LastRow1 = LastRowNum(Sheet1)
LastCol = LastColNum(Sheet1) '<~ last col the same on both sheets
'setup - identify the data block on sheet 2
With Sheet2
Set Range2 = .Range(.Cells(2, 1), .Cells(LastRow2, LastCol))
End With
'setup - identify the data block on sheet 1
With Sheet1
Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
End With
'step 1 - move the data block on sheet 1 down the sheet
' to allow room for the data block from sheet 2
Range1.Cut Destination:=Sheet1.Cells(LastRow2 + 1, 1)
'step 2 - move the data block from sheet 2 into the recently-
' cleared space on sheet 1
Range2.Copy Destination:=Sheet1.Cells(2, 1)
'step 3 - find the NEW last row on sheet 1
LastRow1 = LastRowNum(Sheet1)
'step 4 - use excel's built-in duplicate removal to
' kill all dupes on every column EXCEPT for those
' that might have been updated on sheet 2...
' in this example, Column E is where updates take place
With Sheet1
Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
Range1.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End With
End Sub
'this handy function allows us to find the last row with a one-liner
Public Function LastRowNum(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastRowNum = Sheet.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Else
LastRowNum = 1
End If
End Function
'this handy function allows us to find the last column with a one-liner
Public Function LastColNum(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastColNum = Sheet.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Else
LastColNum = 1
End If
End Function
Running this script results in the following:
Related
I need a loop that will match and select different columns (not in sequential order) and paste them to another sheet all whilst keeping the condition in check. It would also be ideal if when the values get pasted that the formatting for the cell is not carried over, just the value.
Below is the code I am currently using:
Sub Test()
Application.ScreenUpdating = False
Sheets("DATA").Select
lr = Range("B" & Rows.Count).End(xlUp).Row
Range("P3").Select
For i = 3 To lr
If Cells(i, 2) <> "" Then Range(Cells(i, 7), Cells(i, 16), Cells(i, 26)).Copy
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub
The problem is declaring the columns I want the loop to paste. I need the loop to run through the 16th column, check empty values, and then paste the index/matched value in the rows of columns 7,16,and 26 (so not in sequential order).. Any help would be appreciated.
The next code has to do what I understood you need. Please check it and confirm this aspect. It is very fast, working only in memory...
Sub PastingNextPage()
Dim sh As Worksheet, sh1 As Worksheet, arrIn As Variant, arrOut() As Variant
Dim lastRowIn As Long, lastRowOut As Long, nonEmpt As Long, rngP As Range, nrEl As Long
Dim i As Long, j As Long, P As Long
Set sh = Sheets("DATA"): lastRowIn = sh.Range("P" & sh.Rows.count).End(xlUp).Row
Set sh1 = Sheets("Sheet2"): lastRowOut = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row + 1
arrIn = sh.Range("G2:Z" & lastRowIn).Value
nrEl = lastRowIn - Application.WorksheetFunction.CountIf(sh.Range("P2:P" & lastRowIn), "") - 2
P = 10 'column P:P number in the range starting with G:G column
ReDim arrOut(nrEl, 3) 'redim the array to keep the collected values
For i = 1 To lastRowIn - 1
If arrIn(i, P) <> "" Then
arrOut(j, 0) = arrIn(i, 1): arrOut(j, 1) = arrIn(i, P): arrOut(j, 2) = arrIn(i, 20)
j = j + 1
End If
Next i
sh1.Range(sh1.Cells(lastRowOut, "A"), sh1.Cells(lastRowOut + nrEl, "C")).Value = arrOut
End Sub
It does not select anything, you can run it activating any of the two involved sheets. I would recommend to be in "Sheet2" and see the result. If you want to repeat the test, its result will be added after the previous testing resulted rows...
If something unclear or not doing what you need, do not hesitate to ask for clarifications.
I have a problem with a specific excel task. Although I searched the web thoroughly for tips and parts of code I could use, I was not able to get near a functioning solution.
This is my problem:
I have around 30 Worksheets with two columns each.
The number of Rows varies from WS to WS but the two columns on each sheet are equally long.
The first column of each Sheet contains minimum values and the second column holds the respective maximum values.
E.g.
| A | B
1 | 1000 | 1010
2 | 2020 | 2025
Now I need one single column with all values from these intervals including the Max and Min values.
Preferred solution in Column C:
1000, 1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010, 2020, 2021, 2022, 2023, 2024, 2025
I thought of highlighting the two columns and then activating a macro to generate the list. I would then repeat this process for each WS manually. Some sheets have only 4 to 20 rows but some have over 7000 rows.
And if it helps anything: The numbers are postcodes ;-)
I'd be very grateful for any kind of help.
Thanks in advance!
Try this:
Sub Test()
Dim LastRow As Long, ColIndex As Long
Dim i As Long, j As Long
Dim min As Long, max As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ColIndex = 1
For i = 1 To LastRow
min = ws.Cells(i, 1).Value
max = ws.Cells(i, 2).Value
For j = min To max
ws.Cells(ColIndex, 3).Value = j
ColIndex = ColIndex + 1
Next j
Next i
Next ws
End Sub
edited: to have one big string in column "C" (added two lines in each code)
edited 2: added "zip3" solution for having all values listed in "C" column only
you could use either following ways
Option Explicit
Sub zips3()
'list values in column "C" in sequence from all min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
With cell.End(xlToRight).Offset(, 2).Resize(, cell.Offset(, 1).Value - cell.Value + 1)
.FormulaR1C1 = "=RC1+COLUMN()-4"
sht.Range("C" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row).Offset(1).Resize(.Columns.Count) = Application.Transpose(.Value)
.ClearContents
End With
Next cell
If IsEmpty(sht.Range("C1")) Then sht.Range("C1").Delete (xlShiftUp)
Next sht
End Sub
Sub zips()
'list values in column "C" from corresponding min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
Dim j As Long
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
For j = cell.Value To cell.Offset(, 1).Value
cell.End(xlToRight).Offset(, 1) = j
Next j
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
Sub zips2()
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
cell.End(xlToRight).Offset(, 1).Resize(, cell.Offset(, 1).Value - cell.Value + 1).FormulaR1C1 = "=RC1+COLUMN()-3"
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
A solution you can use as you like would be kinda like this:
Public Function getZIPs(rng As Range) As String
Dim myVal As Variant, str As String, i As Long, j As Long
myVal = Intersect(rng, rng.Parent.UsedRange).Value
For i = 1 To UBound(myVal)
If IsNumeric(myVal(i, 1)) And IsNumeric(myVal(i, 2)) And Len(myVal(i, 1)) > 0 And Len(myVal(i, 2)) > 0 Then
If myVal(i, 1) <= myVal(i, 2) Then
For j = myVal(i, 1) To myVal(i, 2)
str = str & ", " & j
Next
End If
End If
Next
getZIPs = Mid(str, 3)
End Function
Put this into a module and then either go for C1: =getZIPs(A1:B1) and auto fill down or directly =getZIPs(A:B) to get all numbers in one cell or use it in a sub to do it automatically.
If you have any questions, just ask :)
EDIT:
If you want it all exactly in the one-column-way, you can use this (should be fast):
Sub getMyList()
Dim sCell As Range, gCell As Range
Set gCell = ActiveSheet.[A1:B1]
Set sCell = ActiveSheet.[C1]
Dim sList As Variant
While IsNumeric(gCell(1)) And IsNumeric(gCell(2)) And Len(gCell(1)) > 0 And Len(gCell(2)) > 0
If gCell(1) = gCell(2) Then
sCell.Value = gCell(1)
Set sCell = sCell.Offset(1)
Else
sList = Evaluate("ROW(" & gCell(1) & ":" & gCell(2) & ")")
sCell.Resize(UBound(sList)).Value = sList
Set sCell = sCell.Offset(UBound(sList))
End If
Set gCell = gCell.Offset(1)
Wend
End Sub
If you have any questions, just ask ;)
I want to copy data from one sheet to another with few conditions:
1. Start with row 1 and column 1 and match if the R1 C2 is not empty then copy the pair R1 C1 and R1 C2 and paste into the other sheet as a new row.
increment the counter for column and match R1 C1 with R1 C3 and so on.
increment the Row when the column counter reaches 10.
I tried the below code but gives compile error as Sub or function not defined.
Please help.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
x = 2
y = 2
Do While Cells(x, 1) <> ""
If Cells(x, y) <> "" Then
Worksheets("Sheet1").Cells(x, 2).Copy
Worksheets("Sheet2").Activate
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(erow)
End If
Worksheets("Sheet1").Activate
y = y + 1
If y = 10 Then x = x + 1
End If
Loop
End Sub
You are geting that error because of > in Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
Avoid the use of using Integer when you are working with rows. Post excel2007, the row count has increased and the Integer may not be able to handle the row number.
Avoid the use of .Activate.
Is this what you are trying? (Untested)
Note: I am demonstrating and hence I am working with the excel cells directly. But in reality, I would be using autofilter & arrays to perform this operation.
Private Sub CommandButton1_Click()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim lRowInput As Long, lRowOutput As Long
Dim i As Long, j As Long
Set wsInput = ThisWorkbook.Worksheets("Sheet1")
Set wsOutput = ThisWorkbook.Worksheets("Sheet2")
With wsInput
lRowInput = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRowInput
If .Cells(i, 2).Value <> "" Then
For j = 3 To 10
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
.Range(.Range(.Cells(i, 1), .Cells(i, 1)).Address & _
"," & _
.Range(.Cells(i, j), .Cells(i, j)).Address).Copy _
wsOutput.Range("A" & lRowOutput)
Next j
End If
Next i
End With
End Sub
I have data ranges in Row 1,2,3 and 4 for columns A:Q. I am trying to create a VBA so it does the following:
Copy Row 1 A:Q, drag and paste n number of rows based on cell O12 starting on Cell A17.
Copy Row 2 A:Q, drag and paste n number of rows based on cell O12 but the paste range should be after what has been pasted for Row 1 range.
Repeat for Row 3 and 4.
So for say of cell O12 states 4, i should be getting 16 rows 4 for each row dragged down.
Any help would be appreciated.
Sub CopyJournalLines()
' Works out last cell with data in columns A or B, copys row 2 and paste within that range (from startrow)
Dim ws As Worksheet
Dim rng1 As Range
Dim LastRow As String
Dim StartRow As String
Dim Copyrange As String
Dim LastYRow As String
Application.ScreenUpdating = False
' Find the last row of data on Concur Extract sheet
Set ws = Sheets("Invoicing")
Set rng1 = ws.Columns("A:B").Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)
' Setting range on Test to copy formulas accross into
StartRow = 17
LastRow = rng1.Row + 1
LastYRow = rng1.Row + 2
If LastYRow < 21 Then
LastYRow = 19
End If
Set ws = Sheets("Vision Import Sheet")
Let Copyrange = StartRow & ":" & LastRow
Let LastYCell = "AB" & LastYRow
' Clear previous content - limited to clear first 1000rows
Rows("17:5000").Cells.Clear
'Selection.ClearContents
If LastRow < 17 Then
GoTo End1
End If
' Copying & pasting row with correct formulas
Rows("1:5").Select
Selection.EntireRow.Hidden = False
Rows("1:1").Select
Selection.Copy
Rows("17:17").Select
ActiveSheet.Paste
Rows("17:17").Select
Selection.Replace What:="#", Replacement:="=", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Rows("17:17").Select
Selection.Copy
Rows(Copyrange).Select
ActiveSheet.Paste
Rows("1:5").Select
Selection.EntireRow.Hidden = True
End1:
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
The copy/paste method should be put in two loops corresponding to two parameters: the number of lines to copy and the number of copies per line.
For the following code, you can choose to copy in the format 111222333 or in the format 123123123 by commenting and un-commenting the two lines that calculate the iCopyRow parameter.
Sub CopyJournalLines2()
Dim wsInv As Worksheet
Dim i As Integer
Dim j As Integer
Dim iStartRow As Integer
Dim iNumCopies As Integer
Dim iNumLines As Integer
Dim iCopyRow As Integer
Dim CopyRange As Range
Dim PasteRange As Range
Set wsInv = ThisWorkbook.Sheets("Invoice Upload")
With wsInv
.Rows("17:5000").Cells.Clear
iStartRow = 17
iNumCopies = .Range("O12").Value
iNumLines = .Range("P12").Value
For i = 1 To iNumLines
Set CopyRange = .Range(.Cells(i, 1), .Cells(i, 17))
iCopyRow = iStartRow + (i - 1) * iNumCopies '---Copies lines in order 111222333444 etc.
'iCopyRow = iStartRow + (i - 1) '---Copies lines in order 123412341234 etc.
Set PasteRange = .Range(.Cells(iCopyRow, 1), .Cells(iCopyRow, 17))
PasteRange.Formula = CopyRange.Formula
If iNumCopies > 1 Then
For j = 2 To iNumCopies
iCopyRow = iStartRow + j - 1 + (i - 1) * iNumCopies '---Copies lines in order 111222333444 etc.
'iCopyRow = iStartRow + i - 1 + ((j - 1) * iNumLines) '---Copies lines in order 123412341234 etc.
.Range(.Cells(iCopyRow, 1), .Cells(iCopyRow, 17)).Formula = PasteRange.Formula
Next j
End If
Next i
End With
End Sub
I have similar question to
[combine Rows with Duplicate Values][1]
Excel VBA - Combine rows with duplicate values in one cell and merge values in other cell
I have data in this format (rows are sorted)
Pub ID CH Ref
no 15 1 t2
no 15 1 t88
yes 15 2 t3
yes 15 2 t3
yes 15 2 t6
compare adjacent rows (say row 4 and 5) , if col 2 and 3 match then if col 4 different merge col4, delete row. if col 2,3,4 match then delete row, don't merge col 4
Desired Output
key ID CH Text
no 15 1 t2 t88
yes 15 2 t3 t6
This first code section doesn't work right
Sub mergeCategoryValues()
Dim lngRow As Long
With ActiveSheet
Dim columnToMatch1 As Integer: columnToMatch1 = 2
Dim columnToMatch2 As Integer: columnToMatch2 = 3
Dim columnToConcatenate As Integer: columnToConcatenate = 4
lngRow = .Cells(65536, columnToMatch1).End(xlUp).row
.Cells(columnToMatch1).CurrentRegion.Sort key1:=.Cells(columnToMatch1), Header:=xlYes
.Cells(columnToMatch2).CurrentRegion.Sort key1:=.Cells(columnToMatch2), Header:=xlYes
Do
If .Cells(lngRow, columnToMatch1) = .Cells(lngRow - 1, columnToMatch1) Then 'check col 2 row lngRow, lngRow-1
If .Cells(lngRow, columnToMatch2) = .Cells(lngRow - 1, columnToMatch2) Then 'check col 3 row lngRow, lngRow-1
If .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow, columnToConcatenate) Then
Else
.Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow - 1, columnToConcatenate) & "; " & .Cells(lngRow, columnToConcatenate)
End If
.Rows(lngRow).Delete
End If
End If
lngRow = lngRow - 1
Loop Until lngRow = 1
End With
Actual Output incorrect because when cells merge t3 will not match t3;t6, my comparison on col 4 will only work in very simple case only.
Actual Output
key ID CH Text
no 15 1 t2; t88
yes 15 2 t3; t3; t6
Therefore, I had to add these two sections to split the Concatenate cells and then remove duplicates
'split cell in Col d to col e+ delimited by ;
With Range("D2:D6", Range("D" & Rows.Count).End(xlUp))
.Replace ";", " ", xlPart
.TextToColumns other:=True
End With
'remove duplicates in each row
Dim x, y(), i&, j&, k&, s$
With ActiveSheet.UsedRange
x = .Value: ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
For i = 1 To UBound(x)
For j = 1 To UBound(x, 2)
If Len(x(i, j)) Then
If InStr(s & "|", "|" & x(i, j) & "|") = 0 Then _
s = s & "|" & x(i, j): k = k + 1: y(i, k) = x(i, j)
End If
Next j: s = vbNullString: k = 0
Next i
.Value = y()
End With
End Sub
With additional code output is
Pub ID CH Ref
no 15 1 t2 t88
yes 15 2 t3 t6
Question: There must be much easier way to do this right than use three different methods? How about inserting new columns 5+ if col 4 items don't match?
Note: Remove duplicates code was found from user nilem at excelforum.
Edit: Col 1 will always be same if Col 2 and 3 match. If solution is much easier we can assume Col 1 is blank and ignore data.
I have printed book lookup table and need to convert to a simple format that will be used in equipment that use a 1960's language which has very limited commands. I am trying to preformat this data so I only need to search for one row that has all info.
Col D final output can be in col D with delimiter or into col D-K (only 8 max Ref) because I will parse to use on other machine. Whatever method is easier.
The canonical practise for deleting rows is to start at the bottom and work toward the top. In this manner, rows are not skipped. The trick here is to find rows above the current position that match columns B and C and concatenate the strings from column D before removing the row. There are several good worksheet formulas that can acquire the row number of a two-column-match. Putting one of them into practise with application.Evaluate would seem to be the most expedient method of collecting the values from column D.
Sub dedupe_and_collect()
Dim rw As Long, mr As Long, wsn As String
With ActiveSheet '<- set this worksheet reference properly!
wsn = .Name
With .Cells(1, 1).CurrentRegion
.RemoveDuplicates Columns:=Array(2, 3, 4), Header:=xlYes
End With
With .Cells(1, 1).CurrentRegion 'redefinition after duplicate removal
For rw = .Rows.Count To 2 Step -1 'walk backwards when deleting rows
If Application.CountIfs(.Columns(2), .Cells(rw, 2).Value, .Columns(3), .Cells(rw, 3).Value) > 1 Then
mr = Application.Evaluate("MIN(INDEX(ROW(1:" & rw & ")+(('" & wsn & "'!B1:B" & rw & "<>'" & wsn & "'!B" & rw & ")+('" & wsn & "'!C1:C" & rw & "<>'" & wsn & "'!C" & rw & "))*1E+99, , ))")
'concatenate column D
'.Cells(mr, 4) = .Cells(mr, 4).Value & "; " & .Cells(rw, 4).Value
'next free column from column D
.Cells(mr, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 4).Value
.Rows(rw).EntireRow.Delete
End If
Next rw
End With
End With
End Sub
The removal of records on a three-column-match is done with the VBA equivalent of the Date ► Data Tools ► Remove Duplicates command. This only considers columns B, C and D and deletes the lower duplicates (keeping the ones closest to row 1). If Column A is important in this respect, additional coding would have to be added.
It's unclear to me whether you wanted column D as delimited string or separate cells as an end result. Could you clarify?
As I wrote above, I would iterate through the data and collect things into the User Defined Object. There is no need for the data to be sorted in this method; and duplicate REF's will be omitted.
One advantage of a User Defined Object is that it makes debugging easier as you can see more clearly what you have done.
We combine every line where ID and CH are the same, by using the property of the Collection object to raise an error if identical keys are used.
So far as combining the Ref's in a single cell with a delimiter, vs individual cells in columns D:K, either can be done simply. I chose to separate into columns, but changing it to combine into a single column would be trivial.
After Inserting the Class Module, you must rename it: cID_CH
You will note I placed the results on a separate worksheets. You could overwrite the original data, but I would advise against that.
Class Module
Option Explicit
Private pID As Long
Private pCH As Long
Private pPUB As String
Private pREF As String
Private pcolREF As Collection
Public Property Get ID() As Long
ID = pID
End Property
Public Property Let ID(Value As Long)
pID = Value
End Property
Public Property Get CH() As Long
CH = pCH
End Property
Public Property Let CH(Value As Long)
pCH = Value
End Property
Public Property Get PUB() As String
PUB = pPUB
End Property
Public Property Let PUB(Value As String)
pPUB = Value
End Property
Public Property Get REF() As String
REF = pREF
End Property
Public Property Let REF(Value As String)
pREF = Value
End Property
Public Property Get colREF() As Collection
Set colREF = pcolREF
End Property
Public Sub ADD(refVAL As String)
On Error Resume Next
pcolREF.ADD refVAL, refVAL
On Error GoTo 0
End Sub
Private Sub Class_Initialize()
Set pcolREF = New Collection
End Sub
Regular Module
Option Explicit
Sub CombineDUPS()
Dim wsSRC As Worksheet, wsRES As Worksheet
Dim vSRC As Variant, vRES() As Variant, rRES As Range
Dim cI As cID_CH, colI As Collection
Dim I As Long, J As Long
Dim S As String
'Set source and results worksheets and results range
Set wsSRC = Worksheets("sheet1")
Set wsRES = Worksheets("sheet2")
Set rRES = wsRES.Cells(1, 1)
'Get Source data
With wsSRC
vSRC = .Range("A2", .Cells(.Rows.Count, "D").End(xlUp))
End With
'Collect and combine data
Set colI = New Collection
On Error Resume Next
For I = 1 To UBound(vSRC, 1)
Set cI = New cID_CH
With cI
.PUB = vSRC(I, 1)
.ID = vSRC(I, 2)
.CH = vSRC(I, 3)
.REF = vSRC(I, 4)
.ADD .REF
S = CStr(.ID & "|" & .CH)
colI.ADD cI, S
If Err.Number = 457 Then
Err.Clear
colI(S).ADD .REF
ElseIf Err.Number <> 0 Then
Debug.Print Err.Number, Err.Description
Stop
End If
End With
Next I
On Error GoTo 0
'Create and populate Results Array
ReDim vRES(0 To colI.Count, 1 To 11)
'Header row
vRES(0, 1) = "Pub"
vRES(0, 2) = "ID"
vRES(0, 3) = "CH"
vRES(0, 4) = "Ref"
'populate array
For I = 1 To colI.Count
With colI(I)
vRES(I, 1) = .PUB
vRES(I, 2) = .ID
vRES(I, 3) = .CH
For J = 1 To .colREF.Count
vRES(I, J + 3) = .colREF(J)
Next J
End With
Next I
'Write the results to the worksheet
Set rRES = rRES.Resize(UBound(vRES, 1) + 1, UBound(vRES, 2))
With rRES
.EntireColumn.Clear
.Value = vRES
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
Range(.Cells(4), .Cells(11)).HorizontalAlignment = xlCenterAcrossSelection
End With
.EntireColumn.AutoFit
End With
End Sub
Original
Processed Results
variant using dictionary below
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dic.Comparemode = vbTextCompare
Dim Cl As Range, x$, y$, i&, Key As Variant
For Each Cl In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
x = Cl.Value & "|" & Cl.Offset(, 1).Value
y = Cl.Offset(, 2).Value
If Not Dic.exists(x) Then
Dic.Add x, Cl.Offset(, -1).Value & "|" & y & "|"
ElseIf Dic.exists(x) And Not LCase(Dic(x)) Like "*|" & LCase(y) & "|*" Then
Dic(x) = Dic(x) & "|" & y & "|"
End If
Next Cl
Range("A2:D" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
i = 2
For Each Key In Dic
Cells(i, "A") = Split(Dic(Key), "|")(0)
Range(Cells(i, "B"), Cells(i, "C")) = Split(Key, "|")
Cells(i, "D") = Replace(Split(Replace(Dic(Key), "||", ";"), "|")(1), ":", ";")
i = i + 1
Next Key
Set Dic = Nothing
End Sub
before
after