Pivot table/summary for multiple sheets

[Meltad]

Hi,

I've got a monthly workbook showing daily delivery details with each day on
a separate tab, but I need a summary (e.g. the same customer may appear on
more than one tab in the month and I need a summary of all their deliveries).
I tried to create a pivot table with a consolidated data source but this
didn't work so now I'm thinking I may need to write a macro. I can't change
the structure of the spreadsheet as we receive a standard format from the
courier.
Any suggestions how I approach this or whther my requirements below are even
possible!?

Ideally I need to:
- Display an input box for the user to enter an order number (found in
column b of all worksheets).
- Search column b in all worksheets (unique number so will either find 1
value or return a fail).
- Find the corresponding customer name from column c, copy that customer name.
- Add a new worksheet at the end of all other current worksheets and paste
the customer name.
- Search column c in all worksheets and where a match is made copy that
whole row and paste into the new summary worksheet.
- Repeat until all rows on all worksheets for that customer have been found
and entered into the summary tab.

THANK YOU!
Mel

 

[SeanC UK]

Hi Mel,

This should do the trick. It will create the new sheet that you want, and
then shift the copied data one column to the right. This means that if you
run the process again then it won't pick up the data in the newly created
sheet.

You can either copy this code into the spreadsheet you are using, or create
an Add-In for it, which would make it available to all new spreadsheets you
receive from your courier. You can run it by pressing ALT + F8 and selecting:

Get_Customers_By_Order

If you use it as an Add-In then this name won't appear, but you can type it
in. If using as an add in then you can create a toolbar button to press to
run the process.

I have run this on a dummy version of your file (invented by me), and it
seems to do what you have asked. If you have any problems running or
implementing this code then let me know and I will try to assist you further,
or if you simply want to know more about how it is working.

I hope this helps.


Public Sub Get_Customers_By_Order()
Dim strOrderID As String
Dim OrderSheet As Worksheet
Dim arrRowArray() As Long
Dim lngFoundRowCount As Long
Dim boolOrderFound As Boolean
Dim strCustomerName As String
Dim NewSheet As Worksheet
Dim lngRowLoopCounter As Long
Dim lngDataRowCounter As Long
strOrderID = InputBox("Please enter order ID", "Order ID")
boolOrderFound = False
For Each OrderSheet In ActiveWorkbook.Worksheets
lngFoundRowCount = Find_Rows(OrderSheet, strOrderID, 2, arrRowArray)
If lngFoundRowCount > 0 Then
boolOrderFound = True
strCustomerName = OrderSheet.Cells(arrRowArray(0), 3)
Exit For
End If
Next
If boolOrderFound = False Then
MsgBox ("Order ID not found.")
Else
Set NewSheet =
ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
lngDataRowCounter = 2
For Each OrderSheet In ActiveWorkbook.Worksheets
If OrderSheet.Name = NewSheet.Name Then
Exit For
End If
ReDim arrRowArray(0)
lngFoundRowCount = Find_Rows(OrderSheet, strCustomerName, 3,
arrRowArray)
If lngFoundRowCount > 0 Then
For lngRowLoopCounter = 0 To lngFoundRowCount - 1
OrderSheet.Activate
OrderSheet.Rows(arrRowArray(lngRowLoopCounter)).Copy
Destination:=NewSheet.Cells(lngDataRowCounter, 1)
lngDataRowCounter = lngDataRowCounter + 1
Next
End If
Next
NewSheet.Activate
With NewSheet
.Columns("A:A").Select
Selection.Insert Shift:=xlToRight
With .Cells(1, 1)
.Value = strCustomerName
.Font.Bold = True
.Select
End With
End With
Set NewSheet = Nothing
End If
End Sub

Private Function Find_Rows(ByVal LocalSheet As Worksheet, ByRef
strLocalSearch As String, _
ByRef intLocalColumn As Integer,
ByRef arrLocalRowArray() As Long) As Long
Dim rngFoundRange As Range
Dim FirstAddress As String
Dim lngOccurrences As Long
With LocalSheet.Columns(intLocalColumn)
Set rngFoundRange = .Find(strLocalSearch, _
after:=Cells(Rows.Count, intLocalColumn), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not rngFoundRange Is Nothing Then
FirstAddress = rngFoundRange.Address
lngOccurrences = 0
Do
ReDim Preserve arrLocalRowArray(lngOccurrences)
arrLocalRowArray(lngOccurrences) = rngFoundRange.Row
lngOccurrences = lngOccurrences + 1
Set rngFoundRange = .FindNext(rngFoundRange)
Loop While Not rngFoundRange Is Nothing And
rngFoundRange.Address <> FirstAddress
Find_Rows = lngOccurrences
Else
Find_Rows = 0
End If
End With
End Function

I don't know how the formatting of this code will be when you copy and paste
it, so it might be the case that it required a little editing after you have
pasted into a VBA module.

Sean.

 

[Meltad]

WOW I wasn't expecting such a full and perfect solution!!!
Thanks so much Sean! This works great, I hardly had to tweak it at all!
Mel

 

[Meltad]

Hi Sean,

OK, so I've tried to add some simple extra bits in but they don't work very
well as your code is a bit more sophisticated than mine!
Basically, on the new sheet (NewSheet) I want to insert the header row as
found on all other worksheets (OrderSheet), then autofit all cells.
And it would be nice to add some totals (sum) under columns G, H and I on
the new sheet. I can do the above but with set sheet names etc so its not
very robust.
Any chance of one last piece of help? Any pointers would be appreciated, I
don't expect you to write the whole code for me

Thanks, Mel

 

[SeanC UK]

Hi Mel,

No problem. I've added a few extra lines, and a new function to determine
the last column of data (otherwise it would have to loop through all columns
when making the subtotals). Incidentally, when writing the subtotals, I have
made it so that it will check the last cell in each column to see if it is i)
numeric, and ii) not empty, just so that it won't subtotal all columns.
However, the subtotal should ignore any text and simply sum all values that
it finds, so you can delete the check it there are some columns that may have
mixed data that you still wish to add up.

Also, I have added a constant: Const lngHeaderRow As Long = 1, assuming that
your headings are on row 1. If not then change this value, the rest should
still work.

Here is the whole thing again, the Find_Rows function has not changed, but I
thought it would be easier for you to copy and paste the whole lot.


Public Sub Get_Customers_By_Order()
Dim strOrderID As String
Dim OrderSheet As Worksheet
Dim arrRowArray() As Long
Dim lngFoundRowCount As Long
Dim boolOrderFound As Boolean
Dim strCustomerName As String
Dim NewSheet As Worksheet
Dim lngRowLoopCounter As Long
Dim lngDataRowCounter As Long
Const lngHeaderRow As Long = 1
Dim intFinalColumn As Integer
Dim intColumnCounter As Integer
strOrderID = InputBox("Please enter order ID", "Order ID")
boolOrderFound = False
For Each OrderSheet In ActiveWorkbook.Worksheets
lngFoundRowCount = Find_Rows(OrderSheet, strOrderID, 2, arrRowArray)
If lngFoundRowCount > 0 Then
boolOrderFound = True
strCustomerName = OrderSheet.Cells(arrRowArray(0), 3)
Exit For
End If
Next
If boolOrderFound = False Then
MsgBox ("Order ID not found.")
Else
Set NewSheet =
ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
lngDataRowCounter = lngHeaderRow + 2
ActiveWorkbook.Worksheets(1).Activate
ActiveSheet.Rows(lngHeaderRow).Copy
Destination:=NewSheet.Cells(lngHeaderRow + 1, 1)
For Each OrderSheet In ActiveWorkbook.Worksheets
If OrderSheet.Name = NewSheet.Name Then
Exit For
End If
ReDim arrRowArray(0)
lngFoundRowCount = Find_Rows(OrderSheet, strCustomerName, 3,
arrRowArray)
If lngFoundRowCount > 0 Then
For lngRowLoopCounter = 0 To lngFoundRowCount - 1
OrderSheet.Activate
OrderSheet.Rows(arrRowArray(lngRowLoopCounter)).Copy
Destination:=NewSheet.Cells(lngDataRowCounter, 1)
lngDataRowCounter = lngDataRowCounter + 1
Next
End If
Next
NewSheet.Activate
intFinalColumn = Get_Last_Column(NewSheet)
If intFinalColumn > 0 Then
For intColumnCounter = 1 To intFinalColumn
If (IsNumeric(NewSheet.Cells(lngDataRowCounter - 1,
intColumnCounter)) = True) _
And
(IsEmpty(NewSheet.Cells(lngDataRowCounter - 1, intColumnCounter)) = False)
Then
NewSheet.Cells(lngDataRowCounter, intColumnCounter) =
"=SUBTOTAL(9," & Chr(64 + intColumnCounter) _
& CStr(lngHeaderRow + 2) & ":" &
Chr(64 + intColumnCounter) & CStr(lngDataRowCounter - 1) & ")"
End If
Next
With NewSheet
.Columns("A:A").Select
Selection.Insert Shift:=xlToRight
With .Cells(1, 1)
.Value = strCustomerName
.Font.Bold = True
.Select
End With
End With
Set NewSheet = Nothing
Else
'SHOULDN'T HAPPEN OR IT WON'T HAVE COPIED ANY DATA
MsgBox ("No data found in new sheet!")
End If
End If
End Sub

Private Function Find_Rows(ByVal LocalSheet As Worksheet, ByRef
strLocalSearch As String, _
ByRef intLocalColumn As Integer,
ByRef arrLocalRowArray() As Long) As Long
Dim rngFoundRange As Range
Dim FirstAddress As String
Dim lngOccurrences As Long
With LocalSheet.Columns(intLocalColumn)
Set rngFoundRange = .Find(strLocalSearch, _
after:=Cells(Rows.Count, intLocalColumn), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not rngFoundRange Is Nothing Then
FirstAddress = rngFoundRange.Address
lngOccurrences = 0
Do
ReDim Preserve arrLocalRowArray(lngOccurrences)
arrLocalRowArray(lngOccurrences) = rngFoundRange.Row
lngOccurrences = lngOccurrences + 1
Set rngFoundRange = .FindNext(rngFoundRange)
Loop While Not rngFoundRange Is Nothing And
rngFoundRange.Address <> FirstAddress
Find_Rows = lngOccurrences
Else
Find_Rows = 0
End If
End With
End Function

Private Function Get_Last_Column(ByVal LocalSheet As Worksheet) As Integer
On Error GoTo LastColumnError
Get_Last_Column = Worksheets(LocalSheet.Name).Cells.Find(What:="*", _
after:=LocalSheet.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Exit Function
LastColumnError:
On Error GoTo 0
Get_Last_Column = 0
End Function


Again, any problems etc, let me know. Always happy to help.

Sean.

 

[Meltad]

Wow again, thanks Sean!
I've removed the check for numeric and empty cells prior to the subtotals,
as one of my required columns may contain blanks, and there are other numeric
fields (eg order number) that I wouldn't want subtotalled... so I'm trying to
change this part of the macro:

For intColumnCounter = 1 To intFinalColumn
NewSheet.Cells(lngDataRowCounter, intColumnCounter) =
"=SUBTOTAL(9," & Chr(64 + intColumnCounter) _
& CStr(lngHeaderRow + 2) & ":" & Chr(64 + intColumnCounter)
& CStr(lngDataRowCounter - 1) & ")"
Next

to pick up columns G, H and I only. Can I set specific columns here?
Thanks, Mel

 

[SeanC UK]

Hi Mel,

Sure, if those are the only columns that you require then you can delete the
Get_Last_Column function, and replace this code:

intFinalColumn = Get_Last_Column(NewSheet)
If intFinalColumn > 0 Then
For intColumnCounter = 1 To intFinalColumn
If (IsNumeric(NewSheet.Cells(lngDataRowCounter - 1,
intColumnCounter)) = True) _
And
(IsEmpty(NewSheet.Cells(lngDataRowCounter - 1, intColumnCounter)) = False)
Then
NewSheet.Cells(lngDataRowCounter, intColumnCounter) =
"=SUBTOTAL(9," & Chr(64 + intColumnCounter) _
& CStr(lngHeaderRow + 2) & ":" &
Chr(64 + intColumnCounter) & CStr(lngDataRowCounter - 1) & ")"
End If
Next
With NewSheet
.Columns("A:A").Select
Selection.Insert Shift:=xlToRight
With .Cells(1, 1)
.Value = strCustomerName
.Font.Bold = True
.Select
End With
End With
Set NewSheet = Nothing
Else
'SHOULDN'T HAPPEN OR IT WON'T HAVE COPIED ANY DATA
MsgBox ("No data found in new sheet!")
End If


With (far more simple):

For intColumnCounter = 7 To 9
NewSheet.Cells(lngDataRowCounter, intColumnCounter) =
"=SUBTOTAL(9," & Chr(64 + intColumnCounter) _
& CStr(lngHeaderRow + 2) & ":" &
Chr(64 + intColumnCounter) & CStr(lngDataRowCounter - 1) & ")"
Next
With NewSheet
.Columns("A:A").Select
Selection.Insert Shift:=xlToRight
With .Cells(1, 1)
.Value = strCustomerName
.Font.Bold = True
.Select
End With
End With
Set NewSheet = Nothing

These subtotals will end up eventually in columns H-J because I've added the
extra column afterwards. I've looped it through 7-9 (G-I) and then added the
loop count to Chr(64) as Chr(65) = A, Chr(66) = B and so on, when creating
the subtotals.

If you wanted to subtotal non-contiguous columns, say C, F and H, then you
could keep the original code, with the Get_Last_Column function, keep the
loop to go through each column in turn but use a select case statement
(replace above code with):

intFinalColumn = Get_Last_Column(NewSheet)
If intFinalColumn > 0 Then
For intColumnCounter = 1 To intFinalColumn
Select Case intColumnCounter
Case 3, 6, 8 '=COLUMNS C, D, AND H
NewSheet.Cells(lngDataRowCounter, intColumnCounter)
= "=SUBTOTAL(9," & Chr(64 + intColumnCounter) _
& CStr(lngHeaderRow + 2) & ":" &
Chr(64 + intColumnCounter) & CStr(lngDataRowCounter - 1) & ")"
Case Else
'DO NOTHING
End Select

Next
With NewSheet
.Columns("A:A").Select
Selection.Insert Shift:=xlToRight
With .Cells(1, 1)
.Value = strCustomerName
.Font.Bold = True
.Select
End With
End With
Set NewSheet = Nothing
Else
'SHOULDN'T HAPPEN OR IT WON'T HAVE COPIED ANY DATA
MsgBox ("No data found in new sheet!")
End If

This method might be better as you can simply add more columns to subtotal
as you feel necessary by Case 3, 6, 8, 9, 2 etc (or Case 7, 8, 9 for now)

Sean.

 

[Meltad]

Brill, thanks Sean.
I used the last option you gave me so I can specify more subtotals if
required.
Thanks you so much for your help!
Mel