I have been given data which is associated by postal code.
I need to count the number of occurrences of certain values in certain columns. Sample data is below.
Survey# PostCode
1 2136
1 2136
2 136
2 2136
1 2137
2 2137
I would like to take this data and produce this type of excel workbook:
Postal Code Survey #1 Survey #2 Survey #3 Survey #4
2136 2 2 0 0
2137 1 1 0 0
I have tried to write code to produce this by using a while loop and the following code. The code works without the while loop.
If you comment out the while look it works, however, I have to select the postal codes I want and then run the macro... it works well when I do this, it adds up all the occurrences of the 1,2,3, or 4 and then places these count values in the appropriate columns.
What I want is for it to run through the column add up all of the occurrences with one postal code (2136), stop and add in the count to the columns. Then begin again counting the occurrences of the next postal code until it gets to the next one and then stop - add in counts.
Sub sort_PC_CPE()
Dim cell As Object
Dim count As Integer
Dim count1 As Integer
Dim count2 As Integer
Dim SV1Count As Integer
Dim SV2Count As Integer
Dim SV3Count As Integer
Dim SV4Count As Integer
Dim ofset As Integer
Dim newVal As Object
'Dim origvalue As Object
count = 0
count1 = 0
count2 = 0
SV1Count = 0
SV2Count = 0
SV3Count = 0
SV4Count = 0
ofset = -1
' if you use the for each cell... and then highlight the cells with the same postal code, this works (also commenting out the while loop)
'For Each cell In Selection
While cell.Offset(ofset, 0).Value = cell.Value
cell.Offset(ofset, 0).Select
ofset = ofset - 1
Wend
'the following works well so long as you manually highlight the cells you want.
If cell.Offset(0, -3).Value = 1 Then
SV1Count = SV1Count + 1
cell.Offset(-count, 1).Value = SV1Count
count = count + 1
ElseIf cell.Offset(0, -3).Value = 2 Then
SV2Count = SV2Count + 1
cell.Offset(-count, 2).Value = SV2Count
count = count + 1
ElseIf cell.Offset(0, -3).Value = 3 Then
SV3Count = SV3Count + 1
cell.Offset(-count, 3).Value = SV3Count
count = count + 1
ElseIf cell.Offset(0, -3).Value = 4 Then
SV4Count = SV4Count + 1
cell.Offset(-count, 4).Value = SV4Count
count = count + 1
End If
End Sub
Why not just use a countifs?
I dropped your sample into a new sheet in column A and B, in column D I put 2136 in row 1 and 2137 in row 2. If you have a large number of postcodes, copy the whole column from the source and paste into column D then click Data and remove Duplicates to get your distinct list.
E1 is this formula:
=COUNTIFS($A:$A,COLUMN(E1)-4,$B:$B,$D1)
Drag across 4 columns and then down 2 rows
results:
2136 2 2 0 0
2137 1 1 0 0
Related
I am trying to create loop which is summing numbers in column N until certain value is reach then write something to cell M.
I have this code working but what I actualy need is to after it found the set value to go to next row and start from 0 untill it finds again the value and then again go to next line and sum from 0 to some value.
Example of data
INV SIZE of INV
26530492 1
26530520 1
26530521 1
26530523 1
26530527 1
26530528 1
26531080 1
26531083 1
26531112 1
26531114 1
26543723 1
26543737 1
26556566 1
26556893 1
in first column are invoices and second column is showing size of the file. The loop would go throug Size column and sum rows until value is reached like 5, then it will continue until another value is reached and so on...it will also add condition to new column like first sum is number 1, second sum 2, etc..
also I am playing with code below
Sub Sum_loop()
'~~> j stands for number of summed segment
j = 1
dbSumTotal = 0
lastrow = Range("N" & Rows.count).End(xlUp).Row
For i = 2 To lastrow Step 1
'~~> in column N are numbers for sum
dbSumTotal = dbSumTotal + Cells(i, "N")
If (dbSumTotal >= 3 Or dbSumTotal <= 3) Then
Cells(i, "O") = j
'~~> reset sum to 0
If dbSumTotal >= 3 Then
dbSumTotal = 0
'~~> for next sum raise the segment number
j = j + 1
End if
End If
Next i
End Sub
Your logic is messed up. The first if statement can never be true. Remove it completely and write the cell value after the counter is incremented.
Sub Sum_loop()
'~~> j stands for number of summed segment
j = 1
dbSumTotal = 0
lastrow = Range("N" & Rows.count).End(xlUp).Row
For i = 2 To lastrow Step 1
'~~> in column N are numbers for sum
dbSumTotal = dbSumTotal + Cells(i, "N")
'~~> write value to cell and reset sum to 0
If dbSumTotal >= 3 Then
dbSumTotal = 0
'~~> for next sum raise the segment number
j = j + 1
End If
Cells(i, "O") = j
Next i
End Sub
This question is related to automating a formula for dynamic range using Macro in excel.
I have 2 columns "A" and "B".
Column A with Application IDs. Application ID in column "A" change dynamically after some iterations i.e. have 18 count, then 43, then 15 and so on...
Column B has corresponding 0s and 1s.
I'm calculating a binomial distribution formula based on the count values using 18 B values, then 43 B values, then 15 B values and so on.
If the Application ID in two rows doesn't match then a formula should be calculated. The formula contains 2-19 row values, than 20-62 row values, than 63-77 row values and so on...
I want it to calculate for 109972 cells. Looking for a macro which can do this.
First formula:
=IF(A19<>A20,BINOM.DIST(COUNTIF($B$2:B19,0),COUNT($B$2:B19),COUNTIF($B$2:B19,0)/COUNT($B$2:B19),FALSE),"")
Second Formula:
=IF(A62<>A63,BINOM.DIST(COUNTIF($B$20:B62,0),COUNT($B$20:B62),COUNTIF($B$20:B62,0)/COUNT($B$20:B62),FALSE),"")
Third Formula (and so on has to calculated)
=IF(A77<>A78,BINOM.DIST(COUNTIF($B$63:B77,0),COUNT($B$63:B77),COUNTIF($B$63:B77,0)/COUNT($B$63:B77),FALSE),"")
If your data is in a sheet named Data, add a command button and then following code. You should check the binomial parameters, cause I'm not used to them.
Private Sub CommandButton1_Click()
Dim lTrialNumber As Long
Dim lFailNumber As Long
Dim lLastRow As Long
Dim i As Long
lLastRow = Worksheets("Data").Cells(1, 1).End(xlDown).Row
lTrialNumber = 0
lFailNumber = 0
For i = 2 To lLastRow 'if data start in row 2. Row 1 for Titles
If Worksheets("Data").Cells(i + 1, 1) <> Worksheets("Data").Cells(i, 1) Then
lTrialNumber = lTrialNumber + 1
If Worksheets("Data").Cells(i, 2) = 0 Then
lFailNumber = lFailNumber + 1
End If
Worksheets("Data").Cells(i, 4) = WorksheetFunction.BinomDist(lFailNumber, lTrialNumber, lFailNumber / lTrialNumber, False)
lTrialNumber = 0
lFailNumber = 0
Else
lTrialNumber = lTrialNumber + 1
If Worksheets("Data").Cells(i, 2) = 0 Then
lFailNumber = lFailNumber + 1
End If
End If
Next
End Sub
I think what I'm trying to do is pretty basic, but I'm brand new to VBA so I'm getting stuck and the answers I've found are close, but not quite right.
I have a list of row entries, like this:
1 4 32 2 4
2 6 33 1 3
1 4 32 2 4
4 2 30 1 5
Notice that rows 1 and 3 are duplicates. I'd like to only have a single instance of each unique row but I don't want to just delete the duplicates, I want to report how many of each type there are. Each row represents an inventory item, so deleting duplicate entries without indicating total quantity would be very bad!
So, my desired output would look something like this, where the additional 6th column counts the total number of instances of each item:
1 4 32 2 4 2
2 6 33 1 3 1
4 2 30 1 5 1
My data sets are larger than just these 5 columns, they're closer to 10 or so, so I'd like to put that last column at the end, rather than to hardcode it to the 6th column (i.e., column "F")
Update:
I found some code that worked with minor tweaking, and it worked this morning, but after messing around with some other macros, when I came back to this one it was telling me that I have a "compile error, wrong number of arguments or invalid property assignment" and it seemed to be unhappy with the "range". Why would working code stop working?
Sub mcrCombineAndScrubDups2()
For Each a In range("A1", Cells(Rows.Count, "A").End(xlUp))
For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row - a.Row
If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then
a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4)
a.Offset(r, 0).EntireRow.Delete
r = r - 1
End If
Next r
Next a
End Sub
Assuming that your data starts from A1 on a worksheet named ws1, the following code removes the duplicated rows. Not by shifting the whole table but deleting the entire row.
Sub deletedupe()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim row1 As String
Dim row2 As String
i = 1
j = 1
k = 1
Do While Sheets("ws1").Cells(i, 1).Value <> ""
row1 = ""
j = 1
Do While Sheets("ws1").Cells(i, j).Value <> ""
row1 = row1 & Sheets("ws1").Cells(i, j).Value & " "
j = j + 1
Loop
k = i + 1
Do While Sheets("ws1").Cells(k, 1).Value <> ""
row2 = ""
j = 1
Do While Sheets("ws1").Cells(k, j).Value <> ""
row2 = row2 & Sheets("ws1").Cells(k, j).Value & " "
j = j + 1
Loop
If row1 = row2 Then
Sheets("ws1").Rows(k).EntireRow.Delete
Else
k = k + 1
End If
Loop
i = i + 1
Loop
End Sub
I have a workbook that has thousands of defined name regions located in various worksheets. I'm trying to extract them all and line them up in another workbook.
Most of the defined name regions are 1 row tall (and hundreds of cols wide)... but a few are 3-4 rows tall.
So for example,
Name1
10 5 10 12 30 10 12 10 5 10 12 30 10 12 ...
Name2
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
For instances where the region is more than one row tall, I'd like to collapse it to a single row by taking the SUM of the entire column.
So Name2 would be copied to the new workbook as the following:
30 33 30 36 90 30 36 30 33 30 36 90 30 36
I have some VBA/VBS written that works perfectly (and fast!) for cases where the region is 1 row tall, but I'm not sure how to handle summing the taller regions in an efficient way.
What's the best way to fill in the question marks below?
My code so far hasn't had to explicitly loop through the cells of a region; I'm hoping that that won't be the case here either. Any advice appreciated!
Dim irow
irow = 0
Dim colsum
'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names
'rem Dont copy any name that isnt visible
If nm.Visible = True Then
'rem Only copy valid references that start with "ByWeek"
If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then
'rem Only copy if the range is one row tall
If nm.RefersToRange.Row.Count = 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
wsDest.Range("A3",wsDest.Cells(3,nm.RefersToRange.Columns.Count+1)).Offset(irow, 1).Value = nm.RefersToRange.Value
irow = irow + 1
' rem If the named region is several rows tall, then squish it into one row by taking SUM of each column
elseif nm.RefersToRange.Row.Count > 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
???????????????????????????????????
irow = irow + 1
End If
End If
End if
Next
You can update your code such that it adds all the cells in the given range (nm.RefersToRange), independently upon the number of cells:
Dim irow
irow = 0
'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names
'rem Dont copy any name that isnt visible
If nm.Visible = True Then
'rem Only copy valid references that start with "ByWeek"
If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then
If nm.RefersToRange.Rows.Count >= 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
Dim totVal As Long: totVal = 0 'I assumed that target values are Long; update this to the proper type is required
For Each cell In nm.RefersToRange.Cells
If (IsNumeric(cell.Value)) Then totVal = totVal + cell.Value
Next
wsDest.Range("A3", wsDest.Cells(3, nm.RefersToRange.Columns.Count + 1)).Offset(irow, 1).Value = totVal
irow = irow + 1
End If
End If
End if
Next
there is no best way as everyone might think their way is the best.
I would suggest using arrays instead of working with the range objects directly as arrays would have been much faster.
Consider
Now running the code
Option Explicit
Sub Main()
Dim lastRow As Long
Dim lastCol As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Dim arr As Variant
arr = Range(Cells(1, 1), Cells(lastRow, lastCol))
ReDim sumArr(UBound(arr, 2)) As Variant
Dim i As Long
Dim j As Long
Dim colSum As Long
For i = LBound(arr, 1) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
colSum = colSum + arr(j, i)
Next j
sumArr(i) = colSum
colSum = 0
Next i
ReDim finalArray(UBound(sumArr) - 1) As Variant
For i = 1 To UBound(sumArr)
finalArray(i - 1) = sumArr(i)
Next i
Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray
End Sub
Results in
The idea to use arrays is taken from here
And all you need to do is modify the range you want to reprint the array to
Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray
So if you use the above code I think all you'll need to change will be
wsDest.Range("A3").Resize(1, UBound(finalArray, 1) + 1) = finalArray
Here's the code I ended using: It loops through each column for the defined named range. It isn't fast, but it works well enough, as 90% of my ranges are just one row tall.
I've just inserted this code where where it says ????...???? in my question above, :
For j = 1 To nm.RefersToRange.Columns.Count
colsum = 0
For i = 1 To nm.RefersToRange.Rows.Count
If IsNumeric(nm.RefersToRange.Cells(i, j).Value) Then
colsum = colsum + nm.RefersToRange.Cells(i, j).Value
End If
Next
wsDest.Range("A3").Offset(irow, j).Value = colsum
Next
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub