i have a code that match the rows in two sheets and paste the matched rows in sheet3 and the unmatched rows in sheet4. The correct output occur when the first row in sheet1 is matched with the first row in sheet2. The problem is that the row(s) with difference doesnt get shown in sheet4
Can anyone help me, where have i made a mistake? I want to have a code that just match the rows no matter which row index they have. It can varie for each input.
My code is:
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("A2:I" & Sheets("Sheet1").Range("H" & Rows.Count).End(3).Row).Value
b = Sheets("Sheet2").Range("A2: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 = 1 To UBound(b, 1)
ky = b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 9)
dic(ky) = i
Next
For i = 1 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(m, n) = a(i, n)
Next
d(m, 8) = a(i, 8) - b(j, 8)
End If
Else
MsgBox "'" & ky & "' not matched on row " & i + 1
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
End Sub
The lines match although they are on different row indexes in sheet1 and sheet2, which is good. The problem is now that the row where there is a difference, doesn't get shown in sheet4 (difference sheet)
Add a message box to identify non-matched keys
For i = 1 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(m, n) = a(i, n)
Next
d(m, 8) = a(i, 8) - b(j, 8)
End If
Else
MsgBox "'" & ky & "' not matched on row " & i + 1
End If
Next
Related
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
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
I'm attempting to combine duplicated rows in a table while summing the numbers in the last column, then creating a new summarized table below.
Only the first duplicated row is being summed. This value then appears in all of the rows below.
Example Table - five Columns
Sub CombineDupesV3()
Dim x As Long
Dim r As Long
Dim arr() As Variant
Dim dic As Object
Const DELIM As String = "|"
Set dic = CreateObject("Scripting.Dictionary")
x = Cells(Rows.Count, 1).End(xlUp).Row
arr = Cells(1, 1).Resize(x, 5).Value
For x = LBound(arr, 1) + 1 To UBound(arr, 1)
If dic.exists(arr(x, 1)) Then
arr(x, 5) = arr(x, 5) + CDbl(Split(dic(arr(x, 1)), DELIM)(3))
Else
dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4) & DELIM & arr(x, 5)
End If
dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4) & DELIM & arr(x, 5)
Debug.Print "X = " & x
Next x
r = UBound(arr, 1) + 2
Application.ScreenUpdating = False
Cells(r, 1).Resize(, 5).Value = Cells(1, 1).Resize(, 5).Value
r = r + 1
For x = 0 To dic.Count - 1
Cells(r + x, 1).Value = dic.keys()(x)
Cells(r + x, 2).Resize(, 4).Value = Split(dic.items()(x), DELIM)
Cells(r + x, 5).Value = CDbl(Cells(r, 5).Value)
Debug.Print "R = " & r
Next x
Application.ScreenUpdating = True
Erase arr
Set dic = Nothing
End Sub
The conversion line in the last loop should address the correct row value r + x
For x = 0 To dic.Count - 1
Cells(r + x, 1).Value = dic.keys()(x)
Cells(r + x, 2).Resize(, 4).Value = Split(dic.items()(x), DELIM)
'>> convert string to double <<
Cells(r + x, 5).Value = CDbl(Cells(r + x, 5).Value)
Next x
Further hints:
Try to fully qualify all range references in order to avoid unwanted results as unqualified cell addresses refer to the active sheet by default which needn't be the one you have in mind :-)
You should either redefine the data range definition or the target range as they might conflict if you run code twice.
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?