I am trying to compare two tables on the same excel sheet between rows. Following is what i am trying to achieve. I have worked something out, but it's not functionnal as it deletes rows...
A B C D E F
E1 40 12 4 4/16/2017 E4
E2 20 1 5 6/22/2016 E2
E1 10 0 4 6/30/2017 E1
E1 40 12 6 4/16/2017 E4
Should turn into :
A B C D E F
E1 40 12 4;6 4/16/2017 E4
E2 20 1 5 6/22/2016 E2
E1 10 0 4 6/30/2017 E1
TASK 1
If column A matches
If column B matches
If column C matches
If column F matches
Then
Concatenate rows on lines D and add a ";" between values
And delete rows that are concatenated.
I have achieved this with this code (just added the condition for F but it's not workind) , but it's not functional already without it, as it doesn't store values in a dictionnary probably and jumps rows, so it doesn't concatenate all of the values in the sheet and skips some too...
Sub TEMPLATE()
Dim lngRow As Long For lngRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
If StrComp(Range("B" & lngRow), Range("B" & lngRow - 1), vbTextCompare) = 0 And
If StrComp(Range("A" & lngRow), Range("A" & lngRow - 1), vbTextCompare) = 0 And
If StrComp(Range("C" & lngRow), Range("C" & lngRow - 1), vbTextCompare) = 0 And
If StrComp(Range("F" & lngRow), Range("F" & lngRow - 1), vbTextCompare) = 0
Then
If Range("D" & lngRow) <> "" Then
Range("D" & lngRow - 1) = Range("D" & lngRow - 1) & ";" & Range("D" & lngRow)
End If
Rows(lngRow).Delete
End If
Next
End Sub
TASK 2
Since this is an update file, I would like to compare every rows on the old file and make changes, and highloght them, if possible. Let's say, if my E1 line up there has been added a value on B, it would highlight B case and add the value.
I don't know how to do this one, I believe it should loop between the old sheet and the updated sheet where I run the previous macro.
Thanks guys for your help !
The code below should complete your TASK 1. It assumes everything is in the first sheet. It works with your example, but I haven't tested it much further so beware. However, I think it's clear enough so you can edit it if needed.
TASK 1:
Sub filter_data()
'Initialize iterator at row 1
i = 0
'Loop through data until no more rows
Do While Sheets(1).Range("A1").Offset(i, 0).Value2 <> ""
'Get values of row
A_val_1 = Sheets(1).Range("A1").Offset(i, 0).Value2
B_val_1 = Sheets(1).Range("A1").Offset(i, 1).Value2
C_val_1 = Sheets(1).Range("A1").Offset(i, 2).Value2
D_val_1 = Sheets(1).Range("A1").Offset(i, 3).Value2
F_val_1 = Sheets(1).Range("A1").Offset(i, 5).Value2
'Loop through data again to check if duplicates
j = i 'Initialize iterator at row i
Do While Sheets(1).Range("A1").Offset(j, 0).Value2 <> ""
If j <> i Then 'Skip selected row
'Get values of row
A_val_2 = Sheets(1).Range("A1").Offset(j, 0).Value2
B_val_2 = Sheets(1).Range("A1").Offset(j, 1).Value2
C_val_2 = Sheets(1).Range("A1").Offset(j, 2).Value2
D_val_2 = Sheets(1).Range("A1").Offset(j, 3).Value2
F_val_2 = Sheets(1).Range("A1").Offset(j, 5).Value2
'If conditions satisfied
If A_val_1 = A_val_2 And B_val_1 = B_val_2 And C_val_1 = C_val_2 And F_val_1 = F_val_2 Then
'Concatenate on D
Sheets(1).Range("A1").Offset(i, 3).Value2 = Sheets(1).Range("A1").Offset(i, 3).Value2 & ";" & D_val_2
'Delete duplicate row
Sheets(1).Rows(j + 1).Delete
'Decrement incrementor by 1 to make up for deleted row
j = j - 1
End If
End If
j = j + 1 'increment
Loop
i = i + 1 'increment
Loop
End Sub
Maybe (?) I'll get back to TASK 2 later, but that should be very straightforward - you just need to loop through all cells, compare an highlight.
EDIT: Task 2 below as far as I understood it. It only checks for difference in the new sheet, highlights differences from old sheet cell-wise and appends the old value to the LEFT of the new value (can be changed). Again, it works with your example.
TASK 2:
Sub compare_data()
'Initialize sheets to compare; only cells on new sheet will be highlighted
old_sheet_idx = 1 'index of old sheet
new_sheet_idx = 2 'index of updated sheet
'Get number of populated rows & column in new sheet
new_sheet_rows = Range(Sheets(new_sheet_idx).Range("A1"), Sheets(new_sheet_idx).Range("A1").End(xlDown)).Count
new_sheet_cols = Range(Sheets(new_sheet_idx).Range("A1"), Sheets(new_sheet_idx).Range("A1").End(xlToRight)).Count
'Clear all formats in new sheet
Sheets(new_sheet_idx).Cells.ClearFormats
'Loop through all rows of new sheet
For i = 1 To new_sheet_rows
'Loop through all cells of the row
For j = 1 To new_sheet_cols
'Get cell value
new_cell = Sheets(new_sheet_idx).Range("A" & i).Offset(0, j - 1).Value2
old_cell = Sheets(old_sheet_idx).Range("A" & i).Offset(0, j - 1).Value2
'Compare
If new_cell <> old_cell Then
Sheets(new_sheet_idx).Range("A" & i).Offset(0, j - 1).Interior.ColorIndex = 6 'highlight yellow
Sheets(new_sheet_idx).Range("A" & i).Offset(0, j - 1).Value2 = old_cell & ";" & new_cell 'concatenate old value;new value
End If
Next j
Next i
End Sub
Related
I have rows of data
Some rows are blank apart from Column C
If Column A is blank then I would like to concatenate Column C with column C from the row above - then delete the row. There could be situations where Column A has 2 or more blank rows, so that would require all those rows in Column C to be merged together
This is the code I used, but I keep getting a mismatch error - not sure where I am going wrong, but the error highlights the line with the offsets in
Sub Merge()
Dim rng As Range
Set ws = Worksheets("test") 'Change your sheet name
Set rng = ws.Range("A1:M5600")
With ws
For i = rng.Rows.Count To 1 Step -1
If .Cells(i, 1) = "" Then
.Cells(i, 3).Offset(-1) = .Cells(i, 3).Offset(-1) & .Cells(i, 3)
.Rows(i).EntireRow.Delete
End If
Next
End With
End Sub
Maybe my comment is not very clear, this is what I mean:
If .Cells(i, 1).Value = "" Then
.Cells(i, 3).Offset(-1).Value = .Cells(i, 3).Offset(-1).Value & ", " & .Cells(i, 3).Value
(I also added ", " for readability purposes)
Edit after comment
.Cells(i, 3).Offset(-1).Value = CStr(.Cells(i, 3).Offset(-1).Value) & ", " & CStr(.Cells(i, 3).Value)
Is that better?
I have a vba code to check if a value of column 2 is duplicate and then if duplicate is found go to check on the same row but different columns if a cells is empty check if it is on weekend(Dates are listed on the first row) and if it is not go back 3 cells and highlight the cell.
I have tried using a nested loop to check first if the value is duplicate then check if the cell is empty and different from weekend
lastRow = Range("B65000").End(xlUp).row
Sheet1.Activate
For i = 2 To lastRow 'loop to run the entire condition
If Trim(Cells(i, 2)) <> "" And Trim(Cells(i, 2)) <> "-" Then
If Application.WorksheetFunction.CountIf(Range("B2:B" & lastRow), Range ("B" & i)) > 1 Then
For col = 5 To 17
If Trim(Cells(i, col)) = "" And Weekday(Cells(1, col)) <> 7 Or 1 Then
Cells(i, col - 3).Interior.Color = vbRed
End If
Next col
End If
End If
Next i
but it ends up highlighting the all the cells instead of just one cell
I want to fetch specific values in column "A" that is using the data below if Column A = "EAST01" then combine or column "B" and "C", count the number of unique occurrences output in Column "I" (TOTAL_TRAILERS) and sum the values in Column "D" (DOCK_TIME), output in Column "J" (TOTAL_DOCK_TIME)
So far this code yields gives me the unique values but I am struggling to figure out where to insert the if statement to get only 'EAST01' and the calculation to get the output.
Since i will be receiving this file everyday, i would like the additional output not to overwrite my previous output but print on the next row under the previous "TOTAL_TRAILERS" and "TOTAL_DOCK_TIME".
Any help will be greatly appreciated.
sample Data
STORE TRAILER REC_DATE DOCK_TIME
EAST01 648295 6/7/2019 10:12:13 AM 19
WEST03 671649 6/7/2019 10:14:47 AM 18
CENTRAL1 V18070 6/7/2019 10:23:31 AM 21
SOUTH04 671652 6/7/2019 10:27:59 AM 22
EAST01 648295 6/7/2019 10:54:12 AM 22
EAST01 648295 6/7/2019 12:03:04 PM 24
EAST01 62517 6/7/2019 12:03:37 PM 23
Sub unikAndSum()
Dim i As Long, N As Long, s As String, r As Range
'Set ws = ThisWorkbook.ActiveSheet
'With ws
'N=.Range("A" & .rows.count.end(xlup).row
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To N
Cells(i, 5) = Cells(i, 2) & " " & Cells(i, 3)
Cells(i, 6) = Cells(i, 5)
Next i
'Range("F:F").RemoveDuplicates Columns:=1, Header:=xlNo
For Each r In Range("F:F").SpecialCells(2).Offset(, 1)
r.Formula = "=COUNTIF(E:E," & r.Offset(, -1).Address & ")"
Next r
End Sub
TOTAL_TRAILER TOTAL_DOCK_TIME
4 88
Next day output here>
The value EAST01 that you are looking for is in Cells(i,1)
The If Statement is in the For Loop
Modified in response to your followup question about the countif slowing down your program.
You can eliminate the for loop because all that the countif statements are doing is putting a 1 in column G. There is no need to do a countif, just put a 1 in column G within the if statement.
Cells(i, 7) = 1
Sub unikAndSum()
Dim i As Long, N As Long, s As String, r As Range
'Set ws = ThisWorkbook.ActiveSheet
'With ws
'N=.Range("A" & .rows.count.end(xlup).row
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To N
If (Cells(i, 1) = "EAST01") Then
Cells(i, 5) = Cells(i, 2) & " " & Cells(i, 3)
Cells(i, 6) = Cells(i, 5)
Cells(i, 7) = 1
End If
Next i
'Range("F:F").RemoveDuplicates Columns:=1, Header:=xlNo
'For Each r In Range("F:F").SpecialCells(2).Offset(, 1)
' r.Formula = "=COUNTIF(E:E," & r.Offset(, -1).Address & ")"
'Next r
End Sub
The group column in my table contains a value as either 1 or 2 . I want to copy the row with value as 1 to Sheet2 and rows with values as 2 to sheet3 using a button. Also it should show error message if cells are left blank or if value is neither 1 nor 2.
Roll no meter width group
112 150 130 1
Since i am new to coding i have following this approach
check if the cell is empty and generate an error message
check if the cell contains value other than 1 or 2 and generate error message
finally copy the row with values as 1 to Sheet2 and rest all in sheet3
I need help in doing this is an effective way. As i have to keep the size of file down
enter code here
Private Sub CommandButton2_Click()
Dim i As Integer
p = Sheet1.Range("l1").Value 'no. of filled cells in the range
Application.DisplayAlerts = False
Sheet1.Activate
''checking if the range is empty
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value = "" Then
MsgBox ("PLEASE ENTER THE SHRINKAGE GROUP FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
'' checking if the range contains values other than 1 or 2
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value <> 1 And Sheet1.Range("l" & i).Value <> 2 Then
MsgBox ("SHADE GROUP DOES NOT EXIST FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
' sort based on the group
Range("a29:L300").Sort _
Key1:=Range("l29"), Header:=xlYes
'count the number of rolls in group 1
Dim x, y As Long
Dim a, b As Integer
x = Range("L" & Rows.Count).End(xlUp).Row
If x < 29 Then x = 29
a = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 1) + 28
Range("M1").Value = a
' count the number of rolls in group 2
y = Range("L" & Rows.Count).End(xlUp).Row
If y < 29 Then y = 29
b = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 2)
Range("n1").Value = b
'' copying groupwise to different sheet
Sheet1.Range("a29", "l" & a).Copy
Sheet2.Range("a5").PasteSpecial xlPasteAll
Sheet2.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
'' copying group 2
Sheet1.Range("a" & a + 1, "l" & a + b).Copy
Sheet5.Range("a5").PasteSpecial xlPasteAll
Sheet5.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Create named ranges for your source data and for the rows after which you want it to be copied. In this example I've used "source", "range1" and "range2". Then the following code copies the source data into the appropriate place:
Sub copyData()
Dim source As Range, range1 As Range, range2 As Range
Dim r As Range
Set source = Range("source")
Set range1 = Range("range1")
Set range2 = Range("range2")
For Each r In source.Rows
If r.Cells(1, 4).Value = 1 Then
copyRow r, range1
ElseIf r.Cells(1, 4).Value = 2 Then
copyRow r, range2
Else
' handle error here
End If
Next r
End Sub
Sub copyRow(data As Range, targetRange As Range)
Set targetRange = targetRange.Resize(targetRange.Rows.Count + 1, targetRange.Columns.Count)
For i = 1 To 3
targetRange.Cells(targetRange.Rows.Count, i).Value = data.Cells(1, i).Value
Next i
End Sub
There's probably a much more elegant way of doing this involving array formulae, but this should do the trick.
For validating that each cell contains only "1" or "2", you can include additional code where I've put a comment, but you'd be better off handling this as a data validation.
I have data in excel that looks like this
{name} {price} {quantity}
joe // 4.99 // 1
lisa // 2.99 // 3
jose // 6.99 // 1
Would it be hard to make a macro that will take the quantity value ("lisa // 3.99 // 3") and add that many rows below it's current location. It would know which rows to copy, and how many rows to insert based on on the quantity column.
Thanks for reading, and feedback is helpful.
This will do what you want, it polls through from the bottom up, if it encounters a number in C and it is > 1 then it will insert the number of rows equal to column C number - 1 then copy the data from the host row.
This will give you 4 equal rows where there is a 4 in column C, I think that is what you were after yes? If you want to ADD the number of rows equal to column C (So a value of 4 would add 4 NEW rows making the total count for that entry become 5) then let me know, it will be simple enough to change this
Sub InsertRowsByQTY()
Dim X As Long
For X = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If IsNumeric(Range("C" & X).text) Then
If Range("C" & X).Value > 1 Then
Rows(X + 1).Resize(Range("C" & X).Value - 1, Columns.Count).Insert
Range("A" & X + 1).Resize(Range("C" & X).Value - 1, Cells(X, Columns.Count).End(xlToLeft).column).Value = Range("A" & X).Resize(1, Cells(X, Columns.Count).End(xlToLeft).column).Value
End If
End If
Next
End Sub
Another method :
Sub insert()
Dim lastrow As Integer, frow As Integer
lastrow = Range("C65536").End(xlUp).Row
frow = 0
For i = 2 To lastrow
If Cells(i, 3) > 1 Then
frow = frow + Cells(i, 3)
End If
Next i
For i = 2 To lastrow + frow
If Cells(i, 3) <> 1 Then
nr = Cells(i, 3)
Rows(i + 1 & ":" & i + nr).Select
Selection.insert Shift:=xlDown
Rows(i & ":" & i + nr).Select
Selection.FillDown
i = i + nr
End If
Next i
End Sub