I been having an issue. What I'm trying to accomplish is compare four columns, if the cells match then return two cells in the same row.
For an example I'm comparing both A&B to D&E with an output of F&G on the same row. The destination doesn't matter much as I can change it.
What I have done only compares two columns, which works, but it also adds other cells that shouldn't apply to that particular line.
Sub Add_XY()
For Each cell In ThisWorkbook.Sheets("Data").UsedRange.Columns("K").Cells
Dim offs As Long: offs = 2 ' <-- Initial offset, will increase after each match
compareValue = cell.Value & "-" & cell.Offset(, 1).Value
ThisWorkbook.Sheets("Data").Range("K6").Value = compareValue
If Not compareValue = "-" Then
For Each compareCell In ThisWorkbook.Sheets("P&T Data").UsedRange.Columns("AI").Cells
'For Each compareCell In ThisWorkbook.Sheets("Data").UsedRange.Columns("A").Cells
If compareCell.Value & "-" & compareCell.Offset(, 1).Value = compareValue Then
ThisWorkbook.Sheets("Data").Range("K6").Value = compareCell.Value & "-" & compareCell.Offset(, 1).Value 'test return value
cell.Offset(, offs).Value = compareCell.Offset(, 5).Value
cell.Offset(, offs + 1).Value = compareCell.Offset(, 6).Value
offs = offs + 4 ' <-- now shift the destination column by 4 for next match
Else
End If
Next compareCell
End If
Next cell
End Sub
Working with the data entered exactly as shown in your picture.
Sub Test()
For Each cell In ThisWorkbook.Sheets("Data").UsedRange.Columns("A").Cells
compareValue = cell.Value & "-" & cell.Offset(0, 1).Value
If Not compareValue = "-" Then
For Each compareCell In ThisWorkbook.Sheets("Data").UsedRange.Columns("A").Cells
If compareCell.Offset(0, 3).Value & "-" & compareCell.Offset(0, 4).Value = compareValue Then
cell.Offset(0, 8) = cell.Offset(0, 5)
cell.Offset(0, 9) = cell.Offset(0, 6)
Else
End If
Next compareCell
End If
Next cell
End Sub
Related
So I am trying to handle some data through VBA and I have a hard time figuring out how to do this the correct and less time consuming way when the data is getting handled.
I have an excel sheet that contains data from A:V with dynamic rows and including headers. But there is a lot of the data I do not need for any reasons.
So, my task is to take column K, P, Q, T, U, and V, and find all the unique combinations/values from this. Then I want to take this unique value and summarize what is in Column O. Afterwards I want to print this to a new sheet, where I have printed all the columns that made the combination. It could look like this:
HeadK
HeadP
HeadQ
HeadT
HeadU
HeadV
HeadO
Proj1
Actual
12
2022
Constrained
5
Proj2
Actual
12
2022
Constrained
1
Proj1
Actual
12
2022
Constrained
3
Proj2
Actual
5
2022
Constrained
10
The idea is just to tell that there can be a lot of combinations with so many columns. But in this case line 1 and 3 could be contained in 1 row, and instead present 8 in head0.
Can anybody help me with this?
I have actually tried some code from chatgpt, but can't get it to work correctly. I know it is not allowed to answer with it, but guess this is my own post, so I can admit my own mistakes....
Sub SummarizeData()
Dim ws As Worksheet
Dim dataRange As Range
Dim uniqueValues As Collection
Dim cell As Range
Dim uniqueValue As Variant
Dim summaryArray() As Variant
Dim summaryIndex As Long
' Define the worksheet
Set ws = ThisWorkbook.Sheets("TimeRegistrations_Billable")
' Define the data range
Set dataRange = ws.Range("K2:V" & ws.Range("K" & ws.Rows.Count).End(xlUp).Row)
' Create a collection to store unique values
Set uniqueValues = New Collection
' Iterate over the data range
For Each cell In dataRange.Columns(1).Cells
uniqueValue = cell.Value & cell.Offset(0, 6).Value & cell.Offset(0, 12).Value & cell.Offset(0, 13).Value & cell.Offset(0, 14).Value
On Error Resume Next
uniqueValues.Add uniqueValue, uniqueValue
On Error GoTo 0
uniqueValues.Add cell.Value, cell.Value & cell.Offset(0, 6).Value & cell.Offset(0, 12).Value & cell.Offset(0, 13).Value & cell.Offset(0, 14).Value & "K"
uniqueValues.Add cell.Offset(0, 10).Value, cell.Value & cell.Offset(0, 6).Value & cell.Offset(0, 12).Value & cell.Offset(0, 13).Value & cell.Offset(0, 14).Value & "T"
uniqueValues.Add cell.Offset(0, 11).Value, cell.Value & cell.Offset(0, 6).Value & cell.Offset(0, 12).Value & cell.Offset(0, 13).Value & cell.Offset(0, 14).Value & "U"
Next cell
' Create an array to store the summarized data
ReDim summaryArray(1 To uniqueValues.Count, 1 To 5)
summaryIndex = 0
' Iterate over the unique values
For Each uniqueValue In uniqueValues
summaryIndex = summaryIndex + 1
summaryArray(summaryIndex, 1) = uniqueValue
summaryArray(summaryIndex, 2) = WorksheetFunction.SumIf(dataRange.Columns(15), uniqueValue, dataRange.Columns(15))
summaryArray(summaryIndex, 3) = uniqueValue & "K"
summaryArray(summaryIndex, 4) = uniqueValue & "T"
summaryArray(summaryIndex, 5) = uniqueValue & "U"
Next uniqueValue
' Add the summarized data to a new worksheet
With ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
.Name = "Tester"
.Range("A1").Resize(uniqueValues.Count, 5).Value = summaryArray
End With
End Sub
So I actually have found 1 way to do it, I just need to remove all the duplicates in column 23 though. But this takes like ages to run, when you have 500k lines.
Don't know if this code makes more sense.
But when the duplicates in data1 column 23 has been removed, I have the data I want as the end gold (and more columns included which is not needed).
Sub uniquevalues()
Dim data1 As Variant, data2 As Variant
Dim lastRowTRB As Long, lastRowdata1 As Long
Dim timer As Double
Dim i As Long, k As Long
lastRowTRB = Worksheets("TimeRegistrations_Billable").Cells(Rows.count, "A").End(xlUp).row
data1 = Worksheets("TimeRegistrations_Billable").Range("A1:X" & lastRowTRB).Value
For i = 2 To lastRowTRB
If i > UBound(data1, 1) Then Exit For
data1(i, 23) = data1(i, 11) & data1(i, 16) & data1(i, 17) & data1(i, 20) & data1(i, 21) & data1(i, 22)
Next i
data2 = data1
For i = 2 To lastRowTRB
If i > UBound(data1, 1) Then Exit For
timer = 0
For k = 2 To lastRowTRB
If k > UBound(data2, 1) Then Exit For
If data2(i, 23) = data2(k, 11) & data2(k, 16) & data2(k, 17) & data2(k, 20) & data2(k, 21) & data2(k, 22) Then
timer = timer + data1(k, 15)
End If
Next k
data1(i, 24) = timer
Next i
With ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
.Name = "Tester"
.Range("A1").Resize(lastRowTRB, 24).Value = data1
End With
I have a large table of data with multiple columns that contain data for mostly triplicates of results. each row contains results from one data point for each subject. most of the subjects have three replicate results, but in some cases, there is only one or two. the sheet is sorted on the subject id column (which is my named range assigned to the variable rng used in the for loop).
this loop tests whether "targetcell" in the range "rng" (which is set to the named range in the sheet that contains the subject id), find the bottom row of any subjects duplicate or triplicate values, and then generates the mean in the newly inserted column:
Set rng = Range("clonesptid")
col = ActiveCell.Column
ActiveCell.Offset(0, 1).EntireColumn.Insert
anchor = col - rng.Column
'MsgBox "cell to test is " & rng(1)
'debugging message box to check where the ptid range is
'MsgBox "Range for ptID is " & rng.Column & " and the active cell address is " & ActiveCell.Address & " and the activecell col is " & anchor
For Each cell In rng
'uncomment the line below to check the cell addresses
' str = str & Cell.Address & " contains " & Cell.Value & "(above=" & Cell.Offset(-1, 0).Value & " below=" & Cell.Offset(1, 0).Value & vbNewLine
' MsgBox "What is our test value?" & vbNewLine & cell.Value
If IsEmpty(cell.Value) = True Then Exit For
targetcell = cell.Value
If cell.Row > 2 Then twoup = cell.Offset(-2, 0).Value
If cell.Row > 1 Then oneup = cell.Offset(-1, 0).Value
onedown = cell.Offset(1, 0).Value
If IsEmpty(targetcell) = False Then
If cell.Row = 1 Then
'adds title with means to first header row
Cells(1, col + 1).Value = Cells(1, col).Value & " mean"
ElseIf cell.Row = 2 And targetcell <> oneup And targetcell <> onedown Then
'test the first value, if unique mean = the value of the cell
cell.Offset(0, anchor + 1).Value = cell.Offset(0, anchor).Value
ElseIf targetcell <> oneup And targetcell <> onedown Then
'for all the rest of the cells in the range, this condition tests for singlets
cell.Offset(0, anchor + 1).Value = cell.Offset(0, anchor).Value
ElseIf targetcell = oneup And targetcell <> twoup And targetcell <> onedown Then
'test for two values
cell.Offset(0, anchor + 1).Value = (cell.Offset(0, anchor).Value + cell.Offset(-1, anchor).Value) / 2
ElseIf targetcell = oneup And targetcell = twoup And targetcell <> onedown Then
'test for three values
cell.Offset(0, anchor + 1).Value = (cell.Offset(0, anchor).Value + cell.Offset(-1, anchor).Value + cell.Offset(-2, anchor).Value) / 3
Else
'this is the first or second replicate of duplicates or triplicates, but not yet the bottom value
cell.Offset(0, anchor + 1).Value = ""
End If
End If
Next
If you have a specific operation like "find all same values up and down" then it's best to move that to a separate method.
Untested:
Sub tester()
Dim rng As Range, cell As Range, dups As Range
Dim lastDup As Range, col As Long, anchor As Long
col = ActiveCell.Column
Cells(1, col + 1).EntireColumn.Insert
Cells(1, col + 1).Value = "Mean"
Set rng = Range("clonesptid")
anchor = col - rng.Column
Set cell = rng.Cells(1)
Do While Len(cell.Value) > 0
Set dups = DupsRange(cell) 'get contiguous range with same value in column
Set lastDup = dups.Cells(dups.Cells.Count)
'calculate your average here
lastDup.Offset(0, anchor + 1) = Application.Average(dups.Offset(0, anchor))
Set cell = lastDup.Offset(1, 0) 'next set
Loop
End Sub
'Given a cell, check up and down to find
' the contiguous same-value range
Public Function DupsRange(c As Range) As Range
Dim cStart As Range, cEnd As Range
If Len(c.Value) = 0 Then Exit Function
Set cStart = c
Set cEnd = c
Do While cStart.Row > 1
If cStart.Offset(-1, 0).Value = c.Value Then _
Set cStart = cStart.Offset(-1, 0) Else Exit Do
Loop
Do While cEnd.Row < Rows.Count
If cEnd.Offset(1, 0).Value = c.Value Then _
Set cEnd = cEnd.Offset(1, 0) Else Exit Do
Loop
Set DupsRange = c.Parent.Range(cStart, cEnd)
End Function
I have stuck with quite odd bug(?) using Find function. For some reason, it can't find next row (n+1), although, it finds any other row in determined range.
Sub band()
Dim laik As String
Dim row1 As Integer
Dim DbSh As Worksheet
Set DbSh = ThisWorkbook.Sheets("Sheet1")
eil = 9 'row in sheet
On Error Resume Next
Do While DbSh.Cells(eil, 1).Value <> ""
laik = DbSh.Cells(eil, 3).Value
row1 = DbSh.Range("C" & eil + 1 & ":C1000").Find(laik, LookIn:=xlValues, LookAt:=xlWhole).row
If Err.Number <> 0 Then Err.Number = 0: GoTo next1
If DbSh.Cells(eil, 4).Value = DbSh.Cells(row1, 4).Value And DbSh.Cells(eil, 6).Value = DbSh.Cells(row1, 6).Value And DbSh.Cells(eil, 8).Value = DbSh.Cells(row1, 8).Value Then
DbSh.Cells(eil, 5).Value = DbSh.Cells(eil, 5).Value & ", " & DbSh.Cells(row1, 5).Value
DbSh.Range(row1 & ":" & row1).EntireRow.Delete
eil = eil - 1 'subtract, still looking for more same values
End If
next1:
eil = eil + 1
Loop
End Sub
Basically, it looks for same values of cells(eil,3) and if it meets some criteria in D, F and H columns, found row is added to "eil" row (E column) and then it is deleted. If same values in C column are next to each other (eil and eil + 1),
row1 = DbSh.Range("C" & eil + 1 & ":C1000").Find(laik, LookIn:=xlValues, LookAt:=xlWhole).row
finds the second available row (from eil+2, eil+3, etc.), skipping eil+1 row. If I remove +1 from Range("C" & eil + 1 & ":C1000"), leaving just Range("C" & eil & ":C1000"), it finds the same row.
For now, I have a workaround, but it could be cool to find out why "Find" skips the following row.
The eil = eil + 1 is always adding 1 to eil. DbSh.Range("C" & eil + 1 & ":C1000").Find is also adding 1. Put together, you are skipping over the 'next' row whenever you find something.
This should rectify the issue.
...
row1 = DbSh.Range("C" & eil & ":C1000").Find(laik, LookIn:=xlValues, LookAt:=xlWhole).row
...
fwiw, I wouold recommend skipping all that 'controlled error' and use a Find/FindNext pair.
I'm trying to compare data between two worksheets. Each Worksheet has three column: A is a concatenation of a Customer and a SKU, B is the sales volume and C is for measuring volume discrepancies. I aim to do two things, check Sheet1 for SKUs that are not in Sheet2 and then, if SKUs match on both sheets, check their volume for quantity differences. If Sheet 1 has a SKU not in Sheet2, I want the record highlighted. I've accomplished this in a primitive way, the entire row gets highlighted. I am, however, having trouble getting the code to check volumes if the Customer & SKU match. I was hoping VBA would retain the values of the cells it was checking, where have I gone wrong and what is the proper implementation? Sorry for being such a n00b.
Sub Again()
Dim lastRow As Integer
Dim rng As Range
lastRow = Sheets("Sheet1").Range("A65000").End(xlUp).Row
For i = 1 To lastRow
Set rng = Sheets("sheet2").Range("A:A").Find(Sheets("Sheet1").Cells(i, 1))
If rng Is Nothing Then
Sheets("Sheet1").Cells(i, 3) = "Item not in sheet2"
Sheets("Sheet1").Cells(i, 1).EntireRow.Interior.Color = vbRed
ElseIf Not rng Is Nothing Then
If Sheets("sheet1").Cells(i, 2).Value - Sheets("sheet2").Cells(i, 2).Value < -5 Then
Sheets("sheet1").Cells(i, 3) = "Sheet2 reports " & Sheets("sheet1").Cells(i, 2).Value - Sheets("sheet2").Cells(i, 2).Value & " more units of volume."
ElseIf Sheets("sheet1").Cells(i, 2) - Sheets("sheet2").Cells(i, 2) > 5 Then
Sheets("sheet1").Cells(i, 3) = "Sheet1 reports " & Sheets("sheet1").Cells(i, 2) - Sheets("sheet2").Cells(i, 2) & " more units of volume."
Else: Sheets("sheet1").Cells(i, 3) = "No or insignificant discrepancy"
End If
End If
Next
End Sub
I think you need to reuse rng like this:
rng.offset(2,0).value
in place of:
Sheets("sheet2").Cells(i, 2).Value
Because all your currently doing is assuming that the matching cell is in exactly the same row as in sheet1.
Your code should then look something like this:
Sub Again()
Dim lastRow As Integer
Dim rng As Range
lastRow = Sheets("Sheet1").Range("A65000").End(xlUp).Row
For i = 1 To lastRow
Set rng = Sheets("sheet2").Range("A:A").Find(Sheets("Sheet1").Cells(i, 1))
If rng Is Nothing Then
Sheets("Sheet1").Cells(i, 3) = "Item not in sheet2"
Sheets("Sheet1").Cells(i, 1).EntireRow.Interior.Color = vbRed
ElseIf Not rng Is Nothing Then
If Sheets("sheet1").Cells(i, 2).Value - rng.offset(0, 2).Value < -5 Then
Sheets("sheet1").Cells(i, 3) = "Sheet2 reports " & Sheets("sheet1").Cells(i, 2).Value - rng.offset(0, 2).Value & " more units of volume."
ElseIf Sheets("sheet1").Cells(i, 2) - rng.offset(0, 2).Value > 5 Then
Sheets("sheet1").Cells(i, 3) = "Sheet1 reports " & Sheets("sheet1").Cells(i, 2) - rng.offset(0, 2).Value & " more units of volume."
Else: Sheets("sheet1").Cells(i, 3) = "No or insignificant discrepancy"
End If
End If
Next
End Sub
Variables. ...If I understand your questions correctly.
dim myString as String
dim myFloat as Float
Sub RebateCalculation()
For x = 2 To 400
If Cells(x, 29) = (-0.2) Then
Range(Cells(x, 25), Cells(x, 25)).Formula = "=0.06*Q4-Q4+O4/M4"
ElseIf Cells(x, 29) = (-0.333333333333333) Then
Range(Cells(x, 25), Cells(x, 25)).Formula = "=0.05*Q4-Q4+O4/M4"
ElseIf Cells(x, 29) = (-1.4) Then
Range(Cells(x, 25), Cells(x, 25)).Formula = "0.05 * Q4 - Q4 + O4 / M4"
Else
Cells(x, 25) = ""
End If
Next x
End Sub
Here is a simple example. to see it work enter 1 to 10 in the first 10 rows of column A and then run it.
I have used FormulaR1C1 because it allows you to easily loop through and modify formula depending on a variable. As you can see you make sure the "R1C1" is entered as a complete string reference to a cell and it can be made up of a few strings and variables "R"& rowNumber & "C" & columnNumber
Sub addEquation()
For i = 1 To 10
If Cells(i, 1).Value = 1 Then
Cells(i, 2).FormulaR1C1 = "=10*R" & i & "C1"
Else
Cells(i, 2).FormulaR1C1 = "=500*R" & i & "C1"
End If
Next i
End Sub
The other option as is instead of specifying all three formula as fixed strings "=0.06*Q4-Q4+Q4/M4" try "=0.06*" & Cell & "-" & cell & "+" & cell & "/" & cell2 where you increment the cell string in in each for loop