I have two sets of monthly data, and I'm trying to determine how this data changes each month.
For example:
Column A is a list of identifiers
Column B is a score (1 through 5) for each identifier
Both column A and column B change month-to-month.
How can I determine the number of identifiers in each 1-5 bucket that are the same and different in month t+1 vs month t=0?
Thanks!
Please, try the next code:
Sub ScoresCompare()
Dim sh0 As Worksheet, sh As Worksheet, lastRow As Long
Dim iCount As Long, i As Long, j As Long
Set sh0 = ActiveSheet 'use here the reference one
Set sh = Workbooks("To be checked").Worksheets(1) 'use here the sheet of the workbook to be checked
lastRow = sh0.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lastRow
For j = 2 To lastRow
If sh0.Range("A" & i).Value = sh.Range("A" & j).Value Then
If sh0.Range("B" & i).Value <> sh.Range("B" & j).Value Then
iCount = iCount + 1: Exit For
End If
End If
Next j
Next i
MsgBox "There are " & iCount & " differences. " & _
lastRow - 1 - iCount & " are unchanged..."
End Sub
Related
I have a list of about 2000 values in column A in Excel, and then a list of the start and end of value ranges in the next two columns. The range values don't correspond to the values in the first column. I want to check, for every value in column A, whether the value falls within ANY of the ranges listed in columns B and C.
So for example, in the image below, see whether A2 falls within B2-C2, B3-C3, OR B4-C4. Then the same again for A3 and A4. For each of these I want true/false to be entered in column D. The true/false value would correspond to the values in column A.
I've been trying to do this in VBA but I'm not totally confident with getting it to search the ranges. Current code is below.
Sub CheckRg()
Dim wk As Worksheet, frow As Long, i As Long
Set wk = Sheet1
frow = wk.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To frow
If wk.Range("A" & i).Value >= wk.Range("B:B").Value And wk.Range("A" & i).Value <= wk.Range("C:C").Value Then
wk.Range("D" & i).Value = "TRUE"
Else
wk.Range("D" & i).Value = "FALSE"
End If
Next i
End Sub
This formula should do the trick without VBA:
=COUNTIFS($B:$B,"<="&A2,$C:$C,">="&A2)<>0
You can use it in your code like this:
Sub CheckRg()
Dim wk As Worksheet, frow As Long, i As Long
Set wk = Sheet1
frow = wk.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To frow
With Excel.WorksheetFunction
wk.Range("D" & i).Value = .CountIfs(wk.Range("B:B"), Evaluate("""<=""" & "&A" & i), wk.Range("C:C"), Evaluate(""">=""" & "&A" & i)) <> 0
End With
Next i
End Sub
An Inefficient Double Loop
A better way to go is presented in the solution by Evil Blue Monkey.
You need to check each cell in column A against each cell pair of columns B and C which requires a second loop that slows down the operation when thousands of rows are expected.
Here's an example of how you could go about that.
Sub CheckRg()
Dim ws As Worksheet: Set ws = Sheet1
Dim lRow As Long: lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim MatchFound As Boolean
For i = 2 To lRow
For j = 2 To lRow
If ws.Range("A" & i).Value >= ws.Range("B" & j).Value _
And ws.Range("A" & i).Value <= ws.Range("C" & j).Value Then
MatchFound = True
Exit For
End If
Next j
If MatchFound Then
ws.Range("D" & i).Value = True
MatchFound = False
Else
ws.Range("D" & i).Value = False
End If
Next i
Application.ScreenUpdating = True
MsgBox "Range checked.", vbInformation
End Sub
Im super new to coding, i hope you guys can help me.
In column A i have some strings and would like to count all the same ones up in Column L. And it should jump to the next row if there is nothig in Column G
How it should look:
A G L
zu=host,out=fr x 1
zu=host,out=fr x 2
zu=host,out=de x 1
zu=host,out=de x 2
zu=host,out=en x 1
zu=host,out=sw x 1
zu=host,out=sw x 2
zu=host,out=nw
zu=host,out=tw x 1
This is my try, which sadly does not work:
Dim i As Integer
Dim ws As Worksheet
Dim counter As Integer
Set ws = ActiveSheet
counter = 1
For i = 1 To 5000
If IsEmpty(ws.Range("A" & i)) Then
Exit For
End If
If ws.Range("A" & i).Value = ws.Range("A" & i + 1).Value Then
ws.Range("L" & i).Value = counter
counter = counter + 1
Exit For
Else: ws.Range("L" & i).Value = 1
counter = 1
Exit For
End If
Next i
MsgBox ("Finished ")
No need for VBA. A simple formula can achieve it. Put =COUNTIF($A$1:A1,A1) in cell L1 and drag it down. I am assuming that your data starts from cell A1.
If you still want VBA, then do this:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LRow As Long
'~~> Set this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row in col A
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Put the formula in the Col L in 1 go!
.Range("L1:L" & LRow).Formula = "=COUNTIF($A$1:A1,A1)"
'~~> Convert formula to values
.Range("L1:L" & LRow).Value = .Range("L1:L" & LRow).Value
End With
End Sub
Screenshot
Having blank rows means it's not a simple as comparing the next or previous rows.
Sub CountUp()
Dim ws As Worksheet
Dim LastRow As Long, i As Long, counter As Long
Dim sLastA As String
Set ws = ActiveSheet
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
counter = 1
For i = 1 To LastRow
If ws.Cells(i, "G") > 0 Then
If ws.Cells(i, "A") = sLastA Then
counter = counter + 1
Else
counter = 1
End If
ws.Cells(i, "L") = counter
sLastA = ws.Cells(i, "A")
End If
Next i
MsgBox ("Finished ")
End Sub
Here are some suggestions to get the original code working:
Option Explicit
Sub Count()
Dim i As Long
Dim ws As Worksheet
Dim counter As Integer
Set ws = ActiveSheet
counter = 1
' Start at row 2
For i = 2 To 10
Debug.Print ("i=" & i)
' This will exit completely if it finds a blank in column G
If IsEmpty(ws.Range("G" & i)) Then
Exit For
End If
'Compare the current row to the previous row
If ws.Range("A" & i).Value = ws.Range("A" & i - 1).Value Then
Debug.Print ("i1=" & i)
counter = counter + 1
' Don''t need to compare to previous value in column L - if current row doesn't match previous row, this just resets counter to 1.
Else
Debug.Print ("i2=" & i)
counter = 1
End If
' Always write counter to column L
ws.Range("L" & i).Value = counter
Next i
MsgBox ("Finished ")
End Sub
I have a subtotal column that starts in cell I11 but I don't know the amount of rows as it will change each time. At the end of the column are multiply functions based on the subtotal.
I am trying to create a macro that will count the amount of rows starting at I11 and will go until the value in column F equals "Value of Work Done"
This is what I have so far:
Sub Total_Amount()
'New_Entry Macro
Dim PPC1 As Worksheet
Dim rowNo As Integer
rowNo = ActiveCell.Row
If PPC1.Range("F11:F").Value = "VALUE OF WORK DONE" Then
With Range("I" & Rows.Count).End(xlUp)
.Offset(1).Formula = "=SUM(I11:" & .Address(0, 0) & ")"
End With
End If
End Sub
The answer still comes up at the end of the column instead of beside "Value of Work Done"
Sub Total_Amount()
'New_Entry Macro
Dim ws As Excel.Worksheet
Dim lRow As Long
Dim lLast As Long
Set ws = Worksheets("PPC 1")
Row = 11
Do While lRow <= ws.UsedRange.Rows.Count
If ws.Range("F" & lRow).Value = "Value of Work Done" Then
lLast = lRow
Exit Do
End If
lRow = lRow + 1
Loop
ws.Range("I" & lRow + 1).Formula = Application.Sum("I11:I" & lLast)
End Sub
Dim ws as excel.worksheet
Dim lRow As Long
Dim lLast as Long
Set ws = Worksheets("PPC 1")
lRow = 11
Do While lRow <= ws.UsedRange.Rows.count
If ws.Range("F" & lRow).Value = "Value of Work Done" then
lLast = lRow
Exit do
End if
lRow = lRow + 1
Loop
Then write the formula to whatever column you want
ws.Range("I" & lLast).Formula = Application.Sum("I11:I" & lLast)
Can anyone help me with this macro to create multiple sub totals in one column? Any help would be great. I have a group of numbers in column Y. which begins at row 16.
The data is listed on every three lines until the end of that section then there is a gap of around thirty lines then it beings again. I want to create a macro to count how many numbers >45 in each section. Put the total 2 rows below the last data point of each section. In column X on the same row place Number>45
Sub Sample()
Dim result As Long, firstrow As Long, lastrow As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Lastrow in Col Y
lastrow = .Range("Y" & .Rows.Count).End(xlUp).Row
'~~> Set First row
firstrow = 16
'~~> Set your range
Set rng = .Range("Y" & firstrow & ":Y" & lastrow)
'~~> Put relevant values
.Range("x" & lastrow + 2).Value = "Total>45"
.Range("y" & lastrow + 2).Value = _
Application.WorksheetFunction.CountIf(rng, ">45")
End With
End Sub
try the below procedure
and loop backwards to ROW=1 like this:
Sub setTotals()
Dim iRow As Integer
Dim iLastRow As Integer
Dim sFormulaTargetAddress As String
iLastRow = ActiveSheet.Range("Y" & ActiveSheet.Rows.Count).End(xlUp).Row
iRow = iLastRow
Do Until iRow = 1
If Range("Y" & iRow).Value <> "" Then
'
' define the section
sFormulaTargetAddress = "Y" & Range("Y" & iRow).End(xlUp).Row & ":Y" & iRow & ""
'
' Put in the COUNTIF > 45 of the current section...
'
Range("Y" & iRow + 2).Formula = "=COUNTIF(" & sFormulaTargetAddress & ","">45"")"
' '
'Range("X" & iRow + 2).Formula = "=COUNTIF(" & sFormulaTargetAddress & ","">45"")"
Range("X" & iRow + 2).value="Numbers > 45"
'
' find the next section
iRow = Range("Y" & iRow).End(xlUp).Row
If Range("Y" & iRow) <> "" Then iRow = Range("Y" & iRow).End(xlUp).Row
Else
iRow = Range("Y" & iRow).End(xlUp).Row
End If
Loop
End Sub
HTH
Philip
I'm running a dataimport macro, and I want to merge all rows in a dataset that have equal values in column x, and then I want to get a row that represents the average of group x[y] x being the column, and y being the value of the column x for that particular grouping.
Is there a simple function to do this, or must I create an extensive loop with a lot of spare cycles?
Explicitation:
So my dataset looks like
A | B | C
1 2 4
1 2 5
2 7 3
2 5 1
3 2 1
1 5 6
Now I want to merge rows by column A value, so all A's with equal value get the rest of their rows averaged so I would get somethin that looked like:
A | B | C
1 3 5
2 6 2
3 2 1
So far I've been trying to loop over the possible values of column A (1 to 10) manually by this function, but it keeps crashing excel, and I can't figure out why, I must have an endless loop somewhere in this function:
Function MergeRows(sheet, column, value)
Dim LastRow
Dim LastCol
Dim numRowsMerged
Dim totalValue
numRowsMerged = 1
LastRow = sheet.UsedRange.Rows.Count
LastCol = sheet.UsedRange.Columns.Count
With Application.WorksheetFunction
For iRow = LastRow - 1 To 1 Step -1
'enter loop if the cell value matches what we're trying to merge
Do While Cells(iRow, column) = value
For iCol = 1 To LastCol
'skip the column that we're going to use as merging value, and skip the column if it contains 3 (ikke relevant)
If Not (iCol = column) And Not (Cells(iRow, iCol) = 3) Then
Cells(iRow, iCol) = (Cells(iRow, iCol) * numRowsMerged + Cells(iRow + 1, iCol)) / (numRowsMerged + 1)
End If
Next iCol
'delete the row merged
Rows(iRow + 1).Delete
Loop
'add one to the total number of rows merged
numRowsMerged = numRowsMerged + 1
Next iRow
End With
End Function
solution
I ended up creating a range that I would gradually extend using Union, like this:
Function GetRowRange(sheet, column, value) As range
Dim LastRow
Dim LastCol
Dim numRowsMerged
Dim totalValue
Dim rowRng As range
Dim tempRng As range
Dim sheetRange As range
numRowsMerged = 1
Set sheetRange = sheet.UsedRange
LastRow = sheet.UsedRange.Rows.Count
LastCol = sheet.UsedRange.Columns.Count
With Application.WorksheetFunction
For iRow = 1 To LastRow Step 1
'enter loop if the cell value matches what we're trying to merge
If (sheetRange.Cells(iRow, column) = value) Then
Set tempRng = range(sheetRange.Cells(iRow, 1), sheetRange.Cells(iRow, LastCol))
If (rowRng Is Nothing) Then
Set rowRng = tempRng
Else
Set rowRng = Union(rowRng, tempRng)
End If
End If
'add one to the total number of rows merged
numRowsMerged = numRowsMerged + 1
Next iRow
End With
Set GetRowRange = rowRng
End Function
Is this what you are trying? Since you wanted VBA code, I have not used Pivots but used a simpler option; formulas to calculate your average.
Option Explicit
Sub Sample()
Dim col As New Collection
Dim wsI As Worksheet, wsO As Worksheet
Dim wsIlRow As Long, wsOlRow As Long, r As Long, i As Long
Dim itm
'~~> Chnage this to the relevant sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> Work with the input sheet
With wsI
wsIlRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> get unique values from Col A
For i = 1 To wsIlRow
On Error Resume Next
col.Add .Range("A" & i).Value, """" & .Range("A" & i).Value & """"
On Error GoTo 0
Next i
End With
r = 1
'~~> Write unique values to Col A
With wsO
For Each itm In col
.Cells(r, 1).Value = itm
r = r + 1
Next
wsOlRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Use a simple formula to find the average
For i = 1 To wsOlRow
.Range("B" & i).Value = Application.Evaluate("=AVERAGE(IF(" & wsI.Name & _
"!A1:A" & wsIlRow & "=" & .Range("A" & i).Value & _
"," & wsI.Name & "!B1:B" & wsIlRow & "))")
.Range("C" & i).Value = Application.Evaluate("=AVERAGE(IF(" & wsI.Name & _
"!A1:A" & wsIlRow & "=" & .Range("A" & i).Value & _
"," & wsI.Name & "!C1:C" & wsIlRow & "))")
Next i
End With
End Sub
SCREENSHOT
This is easy to do with a pivot table.
Here's a picture of the end result.