Collapsing duplicate row entries and count them? - vba

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

Related

VBA continuous sum loop

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

Sum of column values in named region

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

Excel Barcode Scanner Column Data to Row

I am using a barcode scanner to do inventory with large quantities and I want to enter the data into excel. I can change the way that the scanner behaves after each scan to do things like tab, return, etc. but my big problem is that in order to efficiently provide the quantity I have to scan the item code (7 digits) and then scan the quantities from 0 to 9 in succession. Such that 548 is really 5, 4, 8 and when using excel it puts each number into a new cell. What I would like to do, but don't have the VBA chops to do it is to have excel check to see if the length is 7 digits or one digit. For each one digit number it should move the number to the next cell in the same row as the previous 7 digit number such that each successive one digit number is combined as if excel were concatenating the cells. Then it should delete the single digits in the original column and have the next row start with the 7 digit barcode number.
I hope this makes sense.
Example:
7777777
3
4
5
7777778
4
5
6
7777779
7
8
9
Should become:
| 7777777 | 345 |
| 7777778 | 456 |
| 7777779 | 789 |
Thanks!!
I set up my worksheet like this:
then ran the below code
Sub Digits()
Application.ScreenUpdating = False
Dim i&, r As Range, j&
With Columns("B:B")
.ClearContents
.NumberFormat = "#"
End With
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
If Len(r) = 7 Then
j = 1
Do Until ((Len(r.Offset(j, 0).Text) = 7) Or (IsEmpty(r.Offset(j, 0))))
Cells(i, 2) = CStr(Cells(i, 2).Value) & CStr(r.Offset(j, 0))
j = j + 1
Loop
End If
Set r = Nothing
Next
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Len(Cells(i, 1)) < 7 Then Rows(i & ":" & i).Delete
Next i
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
and the results Ive got:
This is what I did with what you started but I think your newer solution will work better. Thank you so much mehow!
Sub Digits()
Application.ScreenUpdating = False
Dim i, arr, r As Range
Dim a, b, c, d, e
Dim y
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
Set a = Cells(i + 1, 1)
Set b = Cells(i + 2, 1)
Set c = Cells(i + 3, 1)
Set d = Cells(i + 4, 1)
Set e = Cells(i + 5, 1)
If Len(a) = 7 Then
y = 0
ElseIf Len(b) = 7 Then
y = 1
ElseIf Len(c) = 7 Then
y = 2
ElseIf Len(d) = 7 Then
y = 3
ElseIf Len(e) = 7 Then
y = 4
Else:
y = 0
End If
If Len(r) = 7 Then
arr = Range("A" & i & ":A" & i + y).Value
Range("B" & i & ":F" & i) = WorksheetFunction.Transpose(arr)
End If
Next
Cells.Replace "#N/A", "", xlWhole
Application.ScreenUpdating = True
End Sub

Listing all the numbers within a range where range is specified in two cells - vba

I have an excel sheet with the following data:
col1 col2 col3 col4
dvdtable 6 52 57
tvunit 2 30 31
I need to copy each row in another sheet, however making 6 copies of the dvdtable row and 2 copies of the tvunit row. (col2 is referring to the quantity). In addition I need to create a new column where for each of the 6 dvdtable rows I include 52,53,54,55,56,57 respectively in the new column. See the result below:
col1 col2 col3
dvdtable 6 52
dvdtable 6 53
dvdtable 6 54
dvdtable 6 55
dvdtable 6 56
dvdtable 6 57
tvunit 2 30
tvunit 2 31
I managed to produce the code that makes multiple copies of rows thanks to another question in your forum, but I am stuck with the last part of the programming, where I need to create the list of numbers within the range given in column 3 and column 4 for each type of furniture.
You likely have to change the sheetnames.
Option Explicit
Sub whyDidIDoThisForYou()
Dim i, j, k As Integer
Dim numbRows As Integer
Dim curWriteRow As Integer
Dim temp As Integer
Dim values() As String
numbRows = Range("a1").End(xlDown).Row - 1 'assumes heading
curWriteRow = 1
ReDim values(1 To numbRows, 1 To 4)
For i = 1 To numbRows
'read all values in from initial datasheet
For j = 1 To 4
values(numbRows, j) = Sheets("Sheet1").Cells(i + 1, j).Value
Next j
'write to next sheet
'get number of things to write
temp = values(numbRows, 4) - values(numbRows, 3)
'start writing the "output" sheet!
For j = 0 To temp
Sheets("Sheet2").Cells(curWriteRow, 1).Value = values(numbRows, 1)
Sheets("Sheet2").Cells(curWriteRow, 2).Value = values(numbRows, 2)
Sheets("Sheet2").Cells(curWriteRow, 3).Value = values(numbRows, 3) + j
curWriteRow = curWriteRow + 1
Next j
Next i
End Sub
You could use arrays as below which is much quicker than writing to ranges cell by cell
The code below
reads the orginal data into a variant array Y
loops through each row of Y (lngCnt2)
runs through that Y by the number of times specifiec in colulmB (lngCnt3)
dumps the new records to a second variant array X
dumps x to a range starting in E1 when finished
Sub SplicenDice()
Dim rng1 As Range
Dim lngCnt As Long
Dim lngCnt2 As Long
Dim lngCnt3 As Long
Dim lngCnt4 As Long
Dim X
Dim Y
Set rng1 = Range([a1], Cells(Rows.Count, "D").End(xlUp))
Y = rng1.Value2
lngCnt = Application.WorksheetFunction.Sum(Range("B:B"))
ReDim X(1 To lngCnt, 1 To 3)
For lngCnt2 = 1 To UBound(Y, 1)
For lngCnt3 = 1 To Y(lngCnt2, 2)
lngCnt4 = lngCnt4 + 1
X(lngCnt4, 1) = Y(lngCnt2, 1)
X(lngCnt4, 2) = Y(lngCnt2, 2)
X(lngCnt4, 3) = Y(lngCnt2, 3) + lngCnt3 - 1
Next
Next
[e1].Resize(UBound(X, 1), UBound(X, 2)).Value2 = X
End Sub

Excel Loop through list,transpose and create a matrix based on cell content

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