i am comparing the data in 2 workbooks, the column headers are in the same order, they are: ID, DepartmentName, Name, SalesAmount, StartDate, End Date.
Currently i am comparing all the cells in sheet 1 to sheet 2 (for example: cell A1 in sheet 1 to cell A1 in sheet 2 ). However, now the data in sheet 2 is in a different order so my current method of comparing will not work.
If sheet 1 contains the correct data, i want to be able to match the correct rows to sheet 2 and check the data still matches. For the rows that are not present in sheet 2 display a table to notify me of which IDs are missing.
Code which compares cell to cell and identifies differences:
For Each mycell In ActiveWorkbook.Worksheets(shtSheet2).UsedRange
If Not mycell.Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbRed
difference = difference + 1
End If
Next
Any advice or help will be greatly appreciated! thank you
You should read down the list of "good" IDs and for each one use the Range.Find method to look for the entry in shtSheet2. If not found, copy the "good" trade data to the output sheet. If found, then loop through the data items comparing them. Here's the code:
Dim sourceId As Range
Dim testIdData As Range
Dim outputRange As Range
Dim cellFound As Range
Dim columnNum As Integer
Dim copyTheData As Boolean
Dim difference As Integer
Const NUM_COLUMNS_DATA As Integer = 6 '
' Assumes that worksheet variables are already defined
Set sourceId = ActiveWorkbook.Worksheets(shtSheet1).Range("A1")
Set testIdData = ActiveWorkbook.Worksheets(shtSheet2).Range("A1")
Set outputRange = ActiveWorkbook.Worksheets(shtSheet3).Range("A1")
' Extend testIdData to cover all rows of data
Set testIdData = testIdData.Resize(testIdData.CurrentRegion.Rows.Count)
Do Until sourceId.Value = ""
copyTheData = False
' Look for ID in test data
Set cellFound = testIdData.Find(What:=sourceId.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If cellFound Is Nothing Then
' This entry not found, so copy to output
copyTheData = True
outputRange.Resize(ColumnSize:=NUM_COLUMNS_DATA).Interior.Color = vbRed
Else
' Test that all the items match
' This assumes that columns are in same order
For columnNum = 2 To NUM_COLUMNS_DATA ' No need to test the ID column
If sourceId.Cells(ColumnIndex:=columnNum).Value <> cellFound.Cells(ColumnIndex:=columnNum).Value Then
outputRange.Cells(ColumnIndex:=columnNum).Interior.Color = vbRed
copyTheData = True
End If
Next columnNum
End If
If copyTheData Then
sourceId.Resize(ColumnSize:=NUM_COLUMNS_DATA).Copy
' Do PasteSpecial to avoid over-writing the ".Interior.Color = vbRed"
outputRange.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Set outputRange = outputRange.Offset(RowOffset:=1)
difference = difference + 1
End If
Set sourceId = sourceId.Offset(RowOffset:=1)
Loop
Remember to test it thoroughly before using it on real data.
Related
So, I have a data sorting problem.
Essentially, I want to sort the cells of Rows 2 through 48 so that they are beneath their approximate values in Row 1 (the ellipses are used in the below pictures as place holders for all other cells within the row; all Rows, 1 to 48, will extend from EG to IB, making each row a total of 100 cells).
The data will often appear as this:
But I require the data of Rows 2 to 48 to be sorted beneath its Row 1 counterpart in approximate value (within 1.2), like this:
Values are now sorted, using Row 1 as the master row to which all other rows are sorted. Cells within Rows 2-48 must be left blank if no cell value within that Row meets the condition of being within 1.2 of its Row 1 correspondent.
My initial code was written like so:
Sub t()
Dim F As Range
Dim Q As Range
For Each F In Range("EG1:IB1").Cells
For Each Q In Range("EG2:IB2").Cells
If Q.Value <= (F.Value + 1.2) Then
F.Offset(1, 0).Value = Q.Value
Exit For
End If
Next Q
Next F
End Sub
This code does not produce the desired result, obviously, but I do not know why. The intent was to iteratively check the data values of Row 1 against Row 2, and if a value with the necessary criteria was found in Row 2 (being within 1.2 of the current Row 1 cell value), then place it beneath its correspondent in Row 1.
So, assuming that:
Row 1 will have data values in all 100 cells, and
Rows 2-48 will NOT have data in all 100 cells, and
Cells that do not contain data will be empty, and
I want to keep the code limited to sorting one row at a time (checking and sorting a single Row against Row 1 per program run, for safety sake)
How can I rewrite (entirely, if need be) my code so that I might sort the data, as exampled in the first picture, to best fit the data organization exampled in the second picture?
Thank you in advance, and please pardon me if this actually turns out to be an incredibly simple solution that I have overlooked!!
Best,
Sorting each row laterally should correct any out-of-order values and 'huddle' them all at the left end of the EG1:IB48 range. After that, inserting a new cell (shifting other values on the row right) should correct the placement.
Sub sort_and_push()
Dim rw As Long, cl As Long
With Worksheets("Sheet4") '<~~ set this correctly!
With .Range("EG1:IB48")
With .Rows(1)
.Cells.sort Key1:=.Rows(1), Order1:=xlAscending, _
Orientation:=xlLeftToRight, Header:=xlNo
End With
For rw = 2 To .Rows.Count
.Rows(rw).Cells.sort Key1:=.Rows(rw), Order1:=xlAscending, _
Orientation:=xlLeftToRight, Header:=xlNo
For cl = 1 To 99
If IsEmpty(.Cells(rw, cl)) Then
Exit For
ElseIf .Cells(rw, cl).Value2 > .Cells(1, cl + 1).Value2 Then
.Cells(rw, cl).Insert Shift:=xlToRight
End If
Next cl
Next rw
End With
End With
End Sub
Try something like this:
Option Explicit
Sub t()
Dim ws As Excel.Worksheet
Dim F As Excel.Range
Dim Q As Excel.Range
Dim J As Long
Dim s As String
Dim SortRange As Excel.Range
Dim HeaderRange As Excel.Range
Const COL1 As Long = 137
Const COLN As Long = 236
' This is the row you're sorting
' You'll probably want to make this a loop
' variable to sort all rows
Const RR As Long = 2
' As a safety measure I'm specifying which worksheet to sort
' to make sure we don't accidentally sort the wrong data.
' Modify this to suit your purposes.
Set ws = ThisWorkbook.Worksheets(1)
Set SortRange = ws.Range(ws.Cells(RR, COL1), ws.Cells(RR, COLN))
Set HeaderRange = ws.Range(ws.Cells(1, COL1), ws.Cells(1, COLN))
' As a first step, I'm sorting row 2.
' If the values out of order there's a potential to accidentally
' overwrite data. For example if you had
' EG EH
' 1 2 5
' 2 4 3
' moving the 4 in row two to column EH would overwrite the 3.
' If the values are already sorted, you could skip this.
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add _
Key:=SortRange, _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With ws.Sort
.SetRange SortRange
.Header = xlNo
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
' I've reversed the nested-ness of the Q and F loops
' Also, I'm traversing the Q loop in reverse order to avoid
For J = COLN To COL1 Step -1
' For J = 142 To 137 Step -1 ' short loop for testing
Set Q = ws.Cells(RR, J)
' Skip blank cells
If Not IsEmpty(Q.Value) Then
' Do the comparison to Row 1
For Each F In HeaderRange.Cells
If Q.Value <= (F.Value + 1.2) Then
ws.Cells(2, F.Column).Value = Q.Value ' Write to correct column
If F.Column <> Q.Column Then
Q.Clear ' Get rid of old value
End If
Exit For
End If
Next F
End If
Next J
GoTo CleanUp
CleanUp:
Set F = Nothing
Set Q = Nothing
Set SortRange = Nothing
Set HeaderRange = Nothing
Set ws = Nothing
Exit Sub
End Sub
Hope this helps
my code is running really slowly and I'm trying to fasten it. The only way I can think of is to do without the last bit of code which does copy, select,paste twice for two different target worksheets. Was wondering if I'm able to change it to something like Destination:= ____ & ____ instead of selecting and pasting twice?
Sub compare()
'compare if the values of two ranges are the same
'Select workbook to prevent mismatch error
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Workbooks("Compare.xlsm").Activate
Dim referencesheetname, newsheetname, outputsheetname As String
referencesheetname = "Reference"
newsheetname = "New"
Dim range1, range2 As Range
'define the variables
Dim referencesheetcols As Integer
Dim range1rows, range1cols, range2rows, range2cols, testrows, testcols, i, j, p, q As Long
Dim bMatches, rowmatched As Boolean
Dim product As String
'Define names for easy reference
product = "Ethylene"
'Set range you wish the macro to search up till
newsheetcols = 3000
referencesheetcols = 3000
'How many rows and columns should we compare?
'Set testcols to 150 to test whole range
testrows = 1
testcols = 200
'Set p for position to place data at (i.e. if p=1, data will be pasted)
p = Sheets(referencesheetname).UsedRange.Rows.Count
q = Sheets("Datasheet").UsedRange.Rows.Count
'Pasted table range data starts from row 7
For l = 1 To newsheetcols
'ActiveWorkbook.Worksheets(newsheetname).Select
'only test if correct product down column B
If CStr(Sheets(newsheetname).Rows(l).Cells(1, 2).Value) = product Then
rowmatched = False
For k = 5 To referencesheetcols
'bmatch = False
'Define range compare rows 6 onwards for both sheets
Set range1 = Sheets(referencesheetname).Rows(k)
Set range2 = Sheets(newsheetname).Rows(l)
' count the rows and columns in each of the ranges
range1rows = range1.Rows.Count
range1cols = range1.Columns.Count
range2rows = range2.Rows.Count
range2cols = range2.Columns.Count
'Check if ranges are the same dimension?
bMatches = (range1rows = range2rows And range1cols = range2cols)
'if same dimensions loop through the cells
If bMatches Then
For i = 1 To testrows
For j = 1 To testcols
If (range1.Cells(i, j).Value <> range2.Cells(i, j).Value) Then
'Conclude that range dimension is not the same
bMatches = False
i = testrows
j = testcols
'Exit loops
End If
Next
Next
End If
'If ranges of two comparison sheets are the same
If bMatches Then
rowmatched = True
k = referencesheetcols
End If
'Sheets(outputsheetname).Cells(1, 1).Value = rowmatched
'Set place to paste data
If (Not (rowmatched) And k = referencesheetcols) Then
'Copy and paste specified number of columns
range2.Resize(1, 300).Copy
Sheets(referencesheetname).Cells(p, 1).Offset(2, 0).Select
ActiveSheet.Paste
p = p + 1
Sheets("Datasheet").Activate
ActiveSheet.Cells(q, 1).Offset(2, 1).Select
ActiveSheet.Paste
q = q + 1
End If
Next
End If
Next
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Something like below should be ok to change to copy - destination.
range2.Resize(1, 300).Copy Destination:=Sheets(referencesheetname).Cells(p, 1).Offset(2, 0)
Although if you really wanted to speed up your code I would say you would need to read the range into an array and then do your processing on the array. looking at the sheet is costly in terms of cpu time, selecting should be avoided where ever possible
You could also turn calculation off and just recalc when you need it too. You could also look up "WITH"'s as these can speed it up a bit too
In an excel spreadsheet I have 3 columns of data. Column A+B have text inputted and column C is numerical (1-5). I will be creating an input box. depending on the input it will filter the results for column C.
For example :
if I inputted G this conditions will filter the results for column C having 1,2 & 4
if i inputted A this conditions will filter the results for column C having 1 & 3
is this possible to do? my thought was these macros to filter the results and then export it to a new spreadsheet. Is there any other way of doing this ? Sorry for the award explanation :S
This uses the Range.AdvancedFilter method further described here to filter your data, based on user input, and copies the filtered data to a second worksheet in the same workbook.
Because AdvancedFilter requires some 'setting-up' the following assumptions have been made in my example. You may need to change these for your requirements.
There are two worksheets, one (called Data) containing your data; and the second (called Results) containing the AdvancedFilter criteria and the copied results. This second sheet is assumed to be a blank sheet. The criteria are programmatically applied to this sheet.
Your Data must have data headings. If you change the heading called 'Criteria' in my example then you will need to also change this in the code.
You can add additional filter criteria within the code should you wish.
If no, or an unknown filter ID is entered into the inputbox, then all the data is copied to the Results sheet. The results sheet is automatically cleared if the Sub is re-run. An example of applying filter value G is shown below:
Option Explicit
Sub advFiltVals()
Dim wsData As Worksheet, wsResult As Worksheet
Dim frstRow As Long, lstRow As Long, stcol As Long, endcol As Long
Dim critStRow As Long, critStCol As Long
Dim copyStRow As Long, copyStCol As Long
Dim filtVal As String
Dim critRng As Range, copyToRng As Range
Set wsData = Sheets("Data")
Set wsResult = Sheets("Results")
'data
frstRow = 1
stcol = 1
endcol = 3
'result
critStRow = 1 'header row
critStCol = 1
copyStRow = 2
copyStCol = 3
With wsResult
.UsedRange.Clear
Set copyToRng = .Cells(copyStRow, copyStCol)
.Cells(critStRow, critStCol).Value = "Criteria"
filtVal = InputBox("Enter filter value.")
Select Case UCase(filtVal)
Case Is = "A"
.Cells(critStRow, critStCol).Offset(1, 0) = 1
.Cells(critStRow, critStCol).Offset(2, 0) = 3
Set critRng = .Range(.Cells(critStRow, critStCol), .Cells(critStRow, critStCol).Offset(2, 0))
Case Is = "G"
.Cells(critStRow, critStCol).Offset(1, 0) = 1
.Cells(critStRow, critStCol).Offset(2, 0) = 2
.Cells(critStRow, critStCol).Offset(3, 0) = 4
Set critRng = .Range(.Cells(critStRow, critStCol), .Cells(critStRow, critStCol).Offset(3, 0))
Case Else
Set critRng = .Cells(critStRow, critStCol)
End Select
End With
With wsData
If .FilterMode = True Then
.ShowAllData
End If
lstRow = .Cells(Rows.Count, endcol).End(xlUp).Row
With .Range(.Cells(frstRow, stcol), .Cells(lstRow, endcol))
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=critRng, CopyToRange:=copyToRng, Unique:=False
End With
End With
End Sub
Dim range_row_aa As Range
Set range_row_aa = Worksheets("Accretion Amort").Range("1:1")
Dim name_column As Range
Set name_column = Worksheets("Accretion Amort").Columns("A:Z")
Dim column_x As Object
For Each column_x In range_row_aa
If column_x = "Balance Change Diff" Then
Sheets("Recon").Range("J3") = "OKKKKK"
End If
Next
If the column on the accretion amort sheet equals balance change diff, I would like to copy/extract the data in that column to the recon sheet.
Would an array be more helpful in this scenario? Perhaps, a function, as I plan to analyze each column in the accretion amort sheet and extract the column data if the column title (all column titles are in row 1) satisfies a criteria.
(Please note the print "OKKKKK" statement is merely a placeholder to test if the For/IF loop worked)
Here is some code that loops through Row 1:
Sub loopThroughRow1()
Dim range_row_aa As Range
Set range_row_aa = Worksheets("Accretion Amort").Rows("1:1")
Dim cell As Object
For Each cell In range_row_aa.Cells
If cell.Value = "Balance Change Diff" Then
Sheets("Accretion Amort").Range("J3") = cell.Address
End If
Next
End Sub
I've used cell.address as the placeholder so we know it finds the last instance of "Balance Change Diff"
This will use the clipboard to move values to the second sheet:
Sub loopThroughRow1()
Dim range_row_aa As Range
Set range_row_aa = Worksheets("Accretion Amort").Rows("1:1")
Dim x As Integer
Dim cell As Object
For Each cell In range_row_aa.Cells
If cell.Value = "Balance Change Diff" Then
cell.EntireColumn.Copy
x = Sheets("recon").Cells(1, Columns.Count).End(xlToLeft).Column
Sheets("recon").Cells(1, x + 1).PasteSpecial Paste:=xlPasteValues
End If
Next
End Sub
This question already has answers here:
How to compare two entire rows in a sheet
(11 answers)
Closed 8 years ago.
Imagine you have two sets of data and the number of rows and columns are the same. Now you want check if data in cells in one set is equal to data in cells with the same relative address in the other set. If thats true for all cells of a row, remove the row from both sets. I can code this very easily by comparing each cell and that's not good for large data sets. See code below for two columns where the two sets of data happen to be in the same sheet side by side with 300 in column offset between them.
Dim RngOb As Range
Dim c As Range
Range("A1", "B1").Select
set RngOb = Range(Selection, Selection.End(xlDown))
For Each c In RngOb.Rows
If c.Cells(1,1).Value = c.Offset(0, 300).Cells(1,1).Value Then
If c.Cells(1,2).Value = c.Offset(0, 300).Cells(1,2).Value Then
c.EntireRow.Delete
End If
End If
Next
My actual data has more than 100 columns and different number of columns from day to day. I'm looking for a smart, fast way to do this for large data sets. I highly appriciate answers, feedback and criticism. :D
Here is a simple way to compare two rows in isomorphic ranges.............in this example row #5 of each range:
Sub RowCompare()
Dim ary1() As Variant
Dim Range1 As Range, Range2 As Range, rr1 As Range, rr2 As Range
Set Range1 = Range("B9:F20")
Set Range2 = Range("I16:M27")
Set rr1 = Range1.Rows(5)
Set rr2 = Range2.Rows(5)
ary1 = Application.Transpose(Application.Transpose(rr1))
ary2 = Application.Transpose(Application.Transpose(rr2))
st1 = Join(ary1, ",")
st2 = Join(ary2, ",")
If st1 = st2 Then
MsgBox "the same"
Else
MsgBox "different"
End If
End Sub
If you have embedded commas in the cells, then choose another character in the JOIN
If I understand your problem correctly, the following code should allow you to do what you want. Within the code, you select the range you wish to process; the first column of each data set, and the number of columns within each data set.
It does assume only two data sets, as you wrote, although that could be expanded. And there are ways of automatically determining the dataset columns, if there is no other data in between.
Option Explicit
Option Base 0
Sub RemoveDups()
Dim I As Long, J As Long
Dim rRng As Range
Dim vRng As Variant, vRes() As Variant
Dim bRng() As Boolean
Dim aColumns, lColumns As Long
Dim colRowsDelete As Collection
'vRng to include from first to last column to be tested
Set rRng = Range("f1", Cells(Rows.Count, "F").End(xlUp)).Resize(columnsize:=100)
vRng = rRng
ReDim bRng(1 To UBound(vRng))
'columns to be tested
'Specify First column of each data set
aColumns = Array(1, 13)
'num columns in each data set
lColumns = 3
For I = 1 To UBound(vRng)
bRng(I) = vRng(I, aColumns(0)) = vRng(I, aColumns(1))
For J = 1 To lColumns - 1
bRng(I) = bRng(I) And (vRng(I, aColumns(0) + J) = vRng(I, aColumns(1) + J))
Next J
Next I
'Rows to Delete
Set colRowsDelete = New Collection
For I = 1 To UBound(bRng)
If bRng(I) = True Then colRowsDelete.Add Item:=I
Next I
'Delete the rows
If colRowsDelete.Count > 0 Then
Application.ScreenUpdating = False
For I = colRowsDelete.Count To 1 Step -1
rRng.Rows(colRowsDelete.Item(I)).EntireRow.Delete
Next I
End If
Application.ScreenUpdating = True
End Sub