View Single Post
 
Old 06-11-2014, 07:32 PM
macropod's Avatar
macropod macropod is offline Windows 7 32bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,467
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Try:
Code:
Sub Summarize()
Application.ScreenUpdating = False
Dim i As Long, j As Long, x As Long, xlWkBk As Workbook, wsDest As Worksheet
Set xlWkBk = ThisWorkbook
With xlWkBk
  Set wsDest = .Sheets("Summary")
  With wsDest
    .UsedRange.ClearContents
    .UsedRange.CurrentRegion.Delete
    xlWkBk.Sheets("inventory").UsedRange.Columns("A:C").Copy
    .Paste Destination:=wsDest.Range("A1")
    .Columns("C:D").Insert Shift:=xlToRight
    .Cells(1, 3).Value = "Brand"
    .Cells(1, 4).Value = "Type"
  End With
  With .Sheets("sales").UsedRange
    For i = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row
      x = 0
      For j = 5 To wsDest.Cells.SpecialCells(xlCellTypeLastCell).Column
        If wsDest.Cells(1, j).Value = .Cells(i, 7).Value Then
          x = j
          Exit For
        End If
      Next
      If x = 0 Then
        x = j
        wsDest.Cells(1, x).Value = .Cells(i, 7).Value
      End If
      For j = 2 To wsDest.Cells.SpecialCells(xlCellTypeLastCell).Row
        If wsDest.Cells(j, 1).Value = .Cells(i, 1).Value Then
          If wsDest.Cells(j, 2).Value = .Cells(i, 2).Value Then
            If wsDest.Cells(j, 5).Value = .Cells(i, 5).Value Then
              If wsDest.Cells(j, 3).Value = "" Then
                wsDest.Cells(j, 3).Value = .Cells(i, 3).Value
              End If
              If wsDest.Cells(j, 4).Value = "" Then
                wsDest.Cells(j, 4).Value = .Cells(i, 4).Value
              End If
              wsDest.Cells(j, x).Value = .Cells(i, 6).Value
            End If
          End If
        End If
      Next
    Next
  End With
  With wsDest
    x = .Cells.SpecialCells(xlCellTypeLastCell).Column + 1
    xlWkBk.Sheets("inventory").UsedRange.Columns("D").Copy
    .Paste Destination:=wsDest.Range(Cells(1, x).Address)
    .Columns.AutoFit
  End With
End With
Application.ScreenUpdating = True
End Sub
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Last edited by macropod; 06-11-2014 at 07:48 PM. Reason: Minor enhancements, so destination sheet needn't be active
Reply With Quote