Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

updating code match based one column instead of four columns

0

hi

after   many   tries   to  mod  the  code  I  need  fixing  somethings  I  try  to  match  data  based on column B  instead  columns B,C,D,E   as in my case   and   the  values   after calculate  should  show  in  column J   but  it  shows  in column K  and  there  is  empty  row  shows  as  in  row  18   

I  hope  some  body  helps  me  to  fix  theses problems 

Sub CollateData_v2()
  Dim d As Object
  Dim ShList As Variant, a As Variant, vals As Variant
  Dim i As Long, j As Long
  Dim s As String

  Set d = CreateObject("Scripting.Dictionary")
  ShList = Split("stock|sales|pur|returns", "|")
  For j = 0 To UBound(ShList)
    With Sheets(ShList(j))
      a = .UsedRange.Value2
      For i = 2 To UBound(a)
        s = Join(Application.Index(a, i, Array(2, 3, 4, 5)), ";")
        If Len(s) > 2 Then

        If Not d.exists(s) Then d(s) = ";;;"
          vals = Split(d(s), ";")
          If IsNumeric(vals(j)) Then
           vals(j) = vals(j) + a(i, 6)
           Else
           vals(j) = a(i, 6)
          End If

            d(s) = Join(vals, ";")

        End If
      Next i
    End With
  Next j
  Application.ScreenUpdating = False
  With Sheets("summary")
    .UsedRange.EntireRow.Delete
    With .Range("B2:C2").Resize(d.Count)
      .Value = Application.Transpose(Array(d.Keys, d.Items))
      With .Columns(2)
        .TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False
        With .Offset(, 5)
          .FormulaR1C1 = "=RC[-4]-RC[-3]+RC[-2]+RC[-1]"
          .Value = .Value
        End With
        .Resize(, 3).EntireColumn.Insert
      End With
      .Columns(1).TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      With .Columns(0)
        .Cells(1).Value = 1
        .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
      End With
    End With
    With .Range("A1:J1")
      .Value = Array("item", "CODE", "BRAND", "TYPE", "MONAFACTURE", "STOCK", "SALES", "PUR", "RETURNS", "BALANCE")
       .Font.Bold = True
  .Interior.Color = RGB(166, 166, 166)
      .EntireColumn.AutoFit
    End With
    With .UsedRange
      .BorderAround xlContinuous
      .Borders(xlInsideVertical).LineStyle = xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
  End With
  Application.ScreenUpdating = True
End Sub
excel
MS Office Version: 2016
posted by: leap (rep: 46) on Fri Oct 22, 2021 at 12:45 pm
Answer
Discuss

Answers

0
Selected Answer

Leap

The empty rows in the results in "summary" sheet were due to some data in rows 18 and 19 of the "stock" worksheet. In your file, use Debug.Print Worksheets("stock").UsedRange.Address in the VBE Intermediate window and you'll get $A$1:$F$19 rather than $A$1:$F$17(so including two seemingly empty rows in 18 and 19). I deleted those (and reformatted the column in fact) which fixed the problem,

The second problem was simply that the formula to calculate column J was applied to column K because the Offset was incorrect. See the change in bold in the code extract below (and note I changed the Sub name and re-assigned to your button):

Sub CollateData_v3()
...
....

With Sheets("summary")
    .UsedRange.EntireRow.Delete
    With .Range("B2:C2").Resize(d.Count)
      .Value = Application.Transpose(Array(d.Keys, d.Items))
      With .Columns(2)
        .TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False
        With .Offset(, 4) ' ### was .Offset(, 5)
          .FormulaR1C1 = "=RC[-4]-RC[-3]+RC[-2]+RC[-1]"
          .Value = .Value
        End With

...
....

These changes are in the attached file plus changes to the code to use just column B as the dictionary key (with other items moved to the dictionary value)- details in the discussion below (owing to length limits).

Note that the summary sheet leaves me without data and that I corrected the spelling to "Manufacture" in the macro and all sheets.

Hope this helps.

posted by: John_Ru (rep: 6142) on Sun Oct 24, 2021 at 4:29 am
Discuss

Discussion

you're  great John  .  that's  works  , but  about  this  line 
 s = Join(Application.Index(a, i, Array(2, 3, 4, 5)), ";")

I wanted  matching   based  on column B  . I  thinks  this  line  depends  on matching four  columns(B,C,D,E) togther , am I right or  wrong ?  just  search  for  way   match on one  colulmn B . I  think  no  need  array as  in   this  line .
leap (rep: 46) Oct 24, '21 at 5:05 am
Thanks for selecting my Answer, Leap.

If you want to match only column B that assumes the Code is unique (and has matching other values in all sheets) then you can replace that line with: 
s = .Cells(i, 2).Value
but then the BRAND, TYPE and MANUFACTURE values would not be captured in the dictionary key (and not displayed in the Summary sheet).
John_Ru (rep: 6142) Oct 24, '21 at 6:57 am
Leap

Try the new file in the revised Answer, that sorts just on column B (as the dictionary key) and adds the other columns plus sheet values to dictionary value. Code changes in bold below:
Sub CollateData_v4()
  Dim d As Object
  Dim ShList As Variant, a As Variant, vals As Variant
  Dim i As Long, j As Long
  Dim s As String
  
  Set d = CreateObject("Scripting.Dictionary")
  ShList = Split("stock|sales|pur|returns", "|")
  For j = 0 To UBound(ShList)
    With Sheets(ShList(j))
      a = .UsedRange.Value2
      For i = 2 To UBound(a)
        s = .Cells(i, 2)
        If Len(s) > 2 Then
          
        If Not d.exists(s) Then d(s) = Join(Application.Index(a, i, Array(3, 4, 5)), ";") & ";;;;"
          vals = Split(d(s), ";")
          If IsNumeric(vals(j + 3)) Then
           vals(j + 3) = vals(j + 3) + a(i, 6)
           Else
           vals(j + 3) = a(i, 6)
          End If
          
            d(s) = Join(vals, ";")
          
        End If
      Next i
    End With
  Next j
  Application.ScreenUpdating = False
John_Ru (rep: 6142) Oct 24, '21 at 7:55 am
... plus this code (whole macro is too long for discussion text limits):
With Sheets("summary")
    .UsedRange.EntireRow.Delete
    With .Range("B2:C2").Resize(d.Count)
      .Value = Application.Transpose(Array(d.Keys, d.Items))
      With .Columns(2)
        .TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False
        With .Offset(, 7) ' ### was .Offset(, 5)
          .FormulaR1C1 = "=RC[-4]-RC[-3]+RC[-2]+RC[-1]"
          .Value = .Value
        End With
        '.Resize(, 3).EntireColumn.Insert '### not needed
      End With
      .Columns(1).TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      With .Columns(0)
        .Cells(1).Value = 1
        .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
      End With
    End With
    With .Range("A1:J1")
      .Value = Array("item", "CODE", "BRAND", "TYPE", "MANUFACTURE", "STOCK", "SALES", "PUR", "RETURNS", "BALANCE")
       .Font.Bold = True
  .Interior.Color = RGB(166, 166, 166)
      .EntireColumn.AutoFit
    End With
    With .UsedRange
      .BorderAround xlContinuous
      .Borders(xlInsideVertical).LineStyle = xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
  End With
  Application.ScreenUpdating = True
End Sub
John_Ru (rep: 6142) Oct 24, '21 at 7:55 am
John 
thanks  again  for  your  updating !
leap (rep: 46) Oct 24, '21 at 8:21 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login