I have a hard problem that I can't resolve in VBA.
I explain you with a simple example :
I have this database in excel.
my aim is to sum value of apple and apple_1 for column 1,2,3 but for column 4, I want put 1 IFI have just one value who is 1 and 0 IF the 2 value ( apple and apple_1) are 0.
of course, I can have sometimes apple_2 apple_3 apple_4 ... ( I just take an easy example)
Here an example of what I want with VBA :
Please, try the next code. It uses a dictionary and array and due to that it should be fast enough eve for larger ranges:
Sub testProcessFruits()
Dim sh As Worksheet, lastR As Long, arr, arr_, arrIt, arrFin
Dim j As Long, i As Long, dict As Object
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
arr = sh.Range("A1:E" & lastR).Value2
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
If InStr(arr(i, 1), "_") > 0 Then
arr_ = Split(arr(i, 1), "_")
If Not dict.Exists(arr_(0)) Then
dict.Add arr_(0), Array(arr(i, 2), arr(i, 3), arr(i, 4))
Else
arrIt = dict(arr_(0))
For j = 0 To UBound(arrIt) - 1
arrIt(j) = arrIt(j) + arr(i, j + 2)
Next j
dict(arr_(0)) = arrIt
End If
Else
If Not dict.Exists(arr(i, 1)) Then
dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 3), arr(i, 4))
Else
arrIt = dict(arr(i, 1))
For j = 0 To UBound(arrIt) - 1
arrIt(j) = arrIt(j) + arr(i, j + 1)
Next j
dict(arr(i, 1)) = arrIt
End If
End If
Next i
ReDim arrFin(1 To dict.count, 1 To 4)
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i)
arrFin(i + 1, 2) = dict.Items()(i)(0)
arrFin(i + 1, 3) = dict.Items()(i)(1)
arrFin(i + 1, 4) = dict.Items()(i)(2)
Next i
With sh.Range("H1")
.Resize(1, 4).Value2 = sh.Range("A1:D1").Value2
.Offset(1).Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
End With
End Sub
Related
Here is a sample of data from my worksheet. It has been sorted in Column B from smallest to largest to show the duplicate Item Codes (highlighted yellow):
Here is a breakdown of the following columns:
Column A - ID, every ID is unique
Column B - Item Code, duplicates appear
Columns C to E - A range of different data, but if two records have the same Item Code (B), the rest of the data (C to E) will remain the same, as seen above
Columns F to L - Week numbers (52 in a year hence back to 1 in column K) contains numeric values. Despite multiple records could have the same Item Code (B), columns could contain different numeric values (notice the red marks in the above screenshot)
I want to merge these records, based on finding duplicate Item Codes (B), resulting in storing the first ID value (A), merging columns C to E and combing columns F to L. The screenshot below shows my desired output.
As you can see, the records have been combined and merged. Those with a red mark indicate how these numeric values have been added together to show a new value when there are 2 or more records with the same Item Code but have multiple numeric values in the same column. If there is only one value, it merges with the rest to create one row per Item Code.
I have looked online for a long time and all I could find was using Consolidate and using VBA code to combine these records in a format that didn't lead to this desired output, including using formulas.
Thank you!
Edit: The above has been answered. However, below is my original data, I thought the solution for the above question could be easily adjusted and applied to the original data, but I have found no luck with the following code:
Sub ConsolidateItemCodes()
Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
Dim i As Long, j As Long, k As Long, dict As Object
Set sh = Sheets("Sample of Original Data") 'use here the sheet you need processing
Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
lastR = sh.Range("F" & sh.Rows.Count).End(xlUp).Row
arrH = sh.Range("A1:CO1").Value2 'the headers
arr = sh.Range("A2:CO" & lastR).Value2 'place the range in an array for faster iteration/processing
ReDim arrVal(0 To 36) 'redim the array keeping the values
'load the dictionary (ItemCodes as unique keys):
Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 6)) Then
For j = 0 To 36: arrVal(j) = arr(i, j + 36): Next j
dict.Add arr(i, 6), Array(Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10), arr(i, 11), arr(i, 12), arr(i, 13), arr(i, 14), arr(i, 15), arr(i, 16), arr(i, 17), arr(i, 18), arr(i, 19), arr(i, 20), arr(i, 21), arr(i, 22), arr(i, 23), arr(i, 24), arr(i, 25), arr(i, 26), arr(i, 27), arr(i, 28), arr(i, 29), arr(i, 30), arr(i, 31), arr(i, 32), arr(i, 33), arr(i, 34), arr(i, 35)), arrVal)
Else
arrIt = dict(arr(i, 6)) 'a dictionary item can be adaptet directly, EXCEPT arrays...
For j = 0 To 36
arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 36)
Next j
dict(arr(i, 6)) = arrIt 'place back the updated jagged array
End If
Next i
'process dictionary content
ReDim arrfin(1 To dict.Count + 1, 1 To UBound(arr, 6))
'place the header in the final array:
For i = 1 To UBound(arrH, 6): arrfin(1, i) = arrH(1, i): Next i
'extract data from dictionary:
k = 1
For j = 0 To dict.Count - 1
k = k + 1
arrIt = dict.Items()(j)
arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = arrIt(0)(1): arrfin(k, 3) = arrIt(0)(2): arrfin(k, 4) = arrIt(0)(3): arrfin(k, 5) = arrIt(0)(4): arrfin(k, 6) = dict.keys()(j)
arrfin(k, 7) = arrIt(0)(5): arrfin(k, 8) = arrIt(0)(6): arrfin(k, 9) = arrIt(0)(7): arrfin(k, 10) = arrIt(0)(8): arrfin(k, 11) = arrIt(0)(9): arrfin(k, 12) = arrIt(0)(10): arrfin(k, 13) = arrIt(0)(11): arrfin(k, 14) = arrIt(0)(12): arrfin(k, 15) = arrIt(0)(13): arrfin(k, 16) = arrIt(0)(14): arrfin(k, 17) = arrIt(0)(15): arrfin(k, 18) = arrIt(0)(16): arrfin(k, 19) = arrIt(0)(17): arrfin(k, 20) = arrIt(0)(18): arrfin(k, 21) = arrIt(0)(19): arrfin(k, 22) = arrIt(0)(20): arrfin(k, 23) = arrIt(0)(21): arrfin(k, 24) = arrIt(0)(22): arrfin(k, 25) = arrIt(0)(23): arrfin(k, 26) = arrIt(0)(24): arrfin(k, 27) = arrIt(0)(25): arrfin(k, 28) = arrIt(0)(26): arrfin(k, 29) = arrIt(0)(27): arrfin(k, 30) = arrIt(0)(28): arrfin(k, 31) = arrIt(0)(29): arrfin(k, 32) = arrIt(0)(30): arrfin(k, 33) = arrIt(0)(31): arrfin(k, 34) = arrIt(0)(32): arrfin(k, 35) = arrIt(0)(33)
For i = 0 To 36: arrfin(k, i + 36) = arrIt(1)(i): Next i
Next j
'drop the processed array content at once:
With destSh.Range("A1").Resize(k, UBound(arrfin, 6))
.Value2 = arrfin
.Rows(1).Font.Bold = True
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
Here is a snippet of my original data. As you can see column A is the same, column B (2) above is actually column F (6), column F (6) is actually column AJ (36) and it ends at column CO (93).
And this is my desired output, similar to the above.
Please, test the next code. It returns (now) in the next sheet against the processed one, but you can set the destination sheet as you want. As I said in my above comment, it uses arrays and a dictionary and should be very fast. Records can be in any order:
Sub ConsolidateItemCodes()
Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
Dim i As Long, j As Long, k As Long, dict As Object
Set sh = ActiveSheet 'use here the sheet you need processing
Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
If sh.FilterMode Then sh.ShowAllData 'to show all data in case of filters...
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arrH = sh.Range("A1:L1").Value2 'the headers
arr = sh.Range("A2:L" & lastR).Value2 'place the range in an array for faster iteration/processing
ReDim arrVal(0 To 6) 'redim the array keeping the values
'load the dictionary (ItemCodes as unique keys):
Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 2)) Then
For j = 0 To 6: arrVal(j) = arr(i, j + 6): Next j
dict.Add arr(i, 2), Array(Array(arr(i, 1), arr(i, 3), arr(i, 4), arr(i, 5)), arrVal)
Else
arrIt = dict(arr(i, 2)) 'a dictionary item can be adaptet directly, EXCEPT arrays...
For j = 0 To 6
arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 6)
Next j
dict(arr(i, 2)) = arrIt 'place back the updated jagged array
End If
Next i
'process dictionary content
ReDim arrfin(1 To dict.count + 1, 1 To UBound(arr, 2))
'place the header in the final array:
For i = 1 To UBound(arrH, 2): arrfin(1, i) = arrH(1, i): Next i
'extract data from dictionary:
k = 1
For j = 0 To dict.count - 1
k = k + 1
arrIt = dict.Items()(j)
arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = dict.keys()(j)
arrfin(k, 3) = arrIt(0)(1): arrfin(k, 4) = arrIt(0)(2): arrfin(k, 5) = arrIt(0)(3)
For i = 0 To 6: arrfin(k, i + 6) = arrIt(1)(i): Next i
Next j
'drop the processed array content at once:
With destSh.Range("A1").Resize(k, UBound(arrfin, 2))
.Value2 = arrfin
.rows(1).Font.Bold = True
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
I tried commenting all code lines, to be easy understood. If something still not clear enough, do not hesitate to ask for clarifications.
Please, send some feedback after testing it.
Option Explicit
Sub aggregate()
Const ITEM_CODE = "F" ' Item Code
Const WK1 = "AJ" ' start of numeric data
Dim wb As Workbook, ws As Worksheet, n As Long, c1 As Long, c2 As Long
Dim c As Long, r As Long, lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Application.ScreenUpdating = False
With ws
lastrow = .Cells(.Rows.Count, ITEM_CODE).End(xlUp).Row
' start and end columns
c1 = .Columns(WK1).Column
c2 = .UsedRange.Columns.Count + .UsedRange.Column - 1
' scan up sheet
For r = lastrow To 3 Step -1
' compare with row above
If .Cells(r, ITEM_CODE) = .Cells(r - 1, ITEM_CODE) Then
For c = c1 To c2
' aggregate if not blank
If Cells(r, c) <> "" Then
.Cells(r - 1, c) = .Cells(r - 1, c) + .Cells(r, c)
End If
Next
'.Rows(r).Interior.ColorIndex = 3
.Rows(r).Delete
n = n + 1
End If
Next
End With
Application.ScreenUpdating = True
MsgBox n & " rows deleted", vbInformation
End Sub
The following code is supposed to convert or transpose data from multiple rows to lesser rows by IDs
Here's sample of data in Sheet1
And this is the desired output
And here's the code I am trying but I got extra columns and not correct headers
Sub Test()
Dim a, tmp, i As Long, ii As Long, t As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
a(1, 2) = a(1, 2) & " 1"
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 2, 2)
tmp = a(i, 2)
a(.Count + 1, 1) = a(i, 1)
a(.Count + 1, 2) = a(i, 3)
a(.Count + 1, 3) = tmp
Else
t = .Item(a(i, 1))(1) + 2
If UBound(a, 2) < t Then
ReDim Preserve a(1 To UBound(a, 1), 1 To t)
a(1, t) = Replace(a(1, 2), "1", t - 1)
End If
a(.Item(a(i, 1))(0), t) = a(i, 2)
.Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
End If
Next i
t = .Count + 1
End With
With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
.CurrentRegion.Clear
.Value = a: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub
I adust the output a little by modifying this line
t = .Item(a(i, 1))(1) + 1
Using Collections
Sub Test2()
Dim ar, dict As Object, k
Dim t As Long, i As Long, r As Long
ar = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ar)
k = ar(i, 1)
If Not dict.exists(k) Then
dict.Add k, New Collection
dict(k).Add ar(i, 3) ' date
End If
dict(k).Add ar(i, 2) ' Item
If dict(k).Count > t Then t = dict(k).Count
Next
ReDim ar(1 To dict.Count + 1, 1 To t + 1)
ar(1, 1) = "ID"
ar(1, 2) = "Date"
For i = 2 To t
ar(1, i + 1) = "MyH " & i - 1
Next
r = 2
For Each k In dict
ar(r, 1) = k
For i = 1 To dict(k).Count
ar(r, i + 1) = dict(k).Item(i)
Next
r = r + 1
Next
With Sheets("Sheet2").Cells(1).Resize(UBound(ar), UBound(ar, 2))
.CurrentRegion.Clear
.Value = ar: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub
I have played around the code and could adust the output but I welcome any other solutions
Sub Test()
Dim a, tmp, i As Long, ii As Long, t As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
a(1, 3) = a(1, 2) & " 1"
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 2, 3)
tmp = a(i, 2)
a(.Count + 1, 1) = a(i, 1)
a(.Count + 1, 2) = a(i, 3)
a(.Count + 1, 3) = tmp
Else
t = .Item(a(i, 1))(1) + 1
If UBound(a, 2) < t Then
ReDim Preserve a(1 To UBound(a, 1), 1 To t)
a(1, t) = Replace(a(1, 3), "1", t - 2)
End If
a(.Item(a(i, 1))(0), t) = a(i, 2)
.Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
End If
Next i
t = .Count + 1
End With
a(1, 2) = "Date"
With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
.CurrentRegion.Clear
.Value = a: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub
i got a data input in sheet1 and sheet2 which gets compared. If there is line(s) in sheet1 that match line(s) in sheet2, then copy and paste the whole line to first possible row in sheet3. It needs to match in column C, D, E, H and I to be a totally match. If everything but column H match, then copy/paste line(s) to sheet4 and state the difference in column H.
So my data is set to have 2 matches and 2 amount differences. The 2 that match is fine in sheet3, but the 2 that doesn't match is the problem, as only one of the lines is shown in sheet4.
Can anyone help me please :)
Code so far:
Sub MatchRows()
Dim a As Variant, b As Variant, c As Variant, d As Variant
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim dic As Object, ky As String
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("Sheet1").Range("A1:I" & Sheets("Sheet1").Range("H" & Rows.Count).End(3).Row).Value
b = Sheets("Sheet2").Range("A1:I" & Sheets("Sheet2").Range("H" & Rows.Count).End(3).Row).Value
ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
ReDim d(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 2 To UBound(b, 1)
ky = b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 9)
dic(ky) = i
Next
For i = 2 To UBound(a, 1)
ky = a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 9)
If dic.exists(ky) Then
j = dic(ky)
If a(i, 8) = b(j, 8) Then
k = k + 1
For n = 1 To UBound(a, 2)
c(k, n) = a(i, n)
Next
c(k, 8) = 0
Else
m = m + 1
For n = 1 To UBound(a, 2)
d(k, n) = a(i, n)
Next
d(k, 8) = a(i, 8) - b(j, 8)
End If
End If
Next
If k > 0 Then Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(a, 2)).Value = c
If m > 0 Then Sheets("Sheet4").Range("A" & Rows.Count).End(3)(2).Resize(m, UBound(a, 2)).Value = d
Sheets(3).UsedRange.Columns.AutoFit
Sheets(4).UsedRange.Columns.AutoFit
End Sub
To color the cells set Interior.Color property.
Dim rng as Range
If k > 0 Then
Set rng = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
With rng.Resize(k, UBound(a, 2))
.Value = c
.Interior.Color = RGB(0, 255, 0) ' green
End With
End If
If m > 0 Then
Set rng = Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1)
With rng.Resize(m, UBound(a, 2))
.Value = d
.Interior.Color = RGB(255, 0, 0) ' red
End With
End If
o = UBound(vSrc, 1)
ReDim vpf(UBound(vSrc, 1))
For t = 1 To UBound(vSrc, 1)
vpf(t) = WorksheetFunction.Max(20 - vSrc(t, UBound(vSrc, 1)), 0)
Cells(20, 9 + t).Value = vpf(t)
Next t
MsgBox "Upper Bound Length is: " & vpf(1)
J = UBound(vSrc, 1)
'y = 1 + 2
Do
For K = 1 To UBound(vSrc, 1)
' For y = 1 To UBnound(vSrc, 1)
vRes(I, K) = vSrc(K, J)
'vpf(I, y) = vSrc(y, J)
'Next y
Next K
J = J - 1
I = I + 3
Loop Until I > UBound(vRes, 1)
With wsSrc
Set rRes = .Cells(lastRow + 2, 9).Resize(UBound(vRes, 1), UBound(vRes, 2) +
With rRes
.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End With
'MsgBox "Upper Bound Length is: " & rRes
End Sub
vSrc, vpf are arrays, and vpf is working gd but the ouput from cells(20,9+t)
is disappearing . i hope now it is better this is the code after what i did
if i want to place the array directly to the cells that i need how to do that?
I have an script built to go into a file in a dir and form an array based off of the data.
How would I print this:
Dim k As Long, x As Long, j As Long ' counters
Dim varArray() As Variant
ReDim varArray(1 To 13, 1 To 1)
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
For j = 1 To .UsedRange.Rows.Count + 1
If .Cells(j, 1) <> "" Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(j, k)
Next
End If
Next
This builds the array, but I now need it printed to the sheet, so I wrote this:
With Workbooks("master.xlsm").Worksheets("Sheet2")
For j = 2 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
ActiveSheet.Cells(j, k) = varArray(k, j)
Next
Next
End With
This works, but now I need to clear out the array after it has printed with a Redim, but this:
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
doesn't clear it after I place it after the last end with
Here's the whole script for the sake of the bigger picture:
Option Explicit
Sub Stuff()
Dim k As Long, x As Long, j As Long ' counters
Dim varArray() As Variant
ReDim varArray(1 To 13, 1 To 1)
Dim MyFile As String
MyFile = Dir("M:\Merge Files\")
If Len(MyFile) <> 0 Then
With ThisWorkbook.Worksheets(1)
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
For j = 1 To .UsedRange.Rows.Count + 1
If .Cells(j, 1) <> "" Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(j, k)
Next
End If
Next
End With
With Workbooks("master.xlsm").Worksheets("Sheet2")
For j = 2 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
ActiveSheet.Cells(j, k) = varArray(k, j)
Next
Next
End With
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
End If
End Sub