word count

[leebre]

I have part numbers for different regions that are the same and want get a grand total. my work book consists of 31 spreadsheets where the part numbers are listed. I would like to get the total number of duplicate part numbers within the entire workbook on one page listed as
partnumber, qty

any one know how I can do this?

 

[Diffy]

Hello,

I am afraid you will need to be more specific. It is certainly possible to sum the sheets to get a grand total, but could you post an example of how the data is set up, and provide ranges, criteria for summing etc.

Thanks

 

[stanleydgromjr]

leebre,

What column are the part numbers in for the 31 worksheets?

What is the name of the summary worksheet?

Have a great day,
Stan

 

[leebre]

Here is the example:

20 different regions have this part # FC9681CPU209

each region has 20 for easy math

the main page would show:
PART NUMBER QTY
FC9681CPU209 400


I would like one total page that will calculate the total from all pages and display beside the part number so I don't have to go through all 20 sheets and count

 

[leebre]

all data is in column A and the summary sheet is just called summary

 

[stanleydgromjr]

leebre,

Please TEST this FIRST in a COPY of your workbook.


Press and hold down the 'ALT' key, and press the 'F11' key.

Insert a Module in your VBAProject, Microsoft Excel Objects

Copy the below code, and paste it into the Module1.

Option Explicit
Sub CountDuplicatePartNumbers()
'
' CountDuplicatePartNumbers Macro
' Macro created 08/10/2007 by Stanley D. Grom, Jr.
'
    Dim lngWsLastRow As Long
    Dim lngSummaryLastRow As Long
    Dim Wb As Workbook
    Dim Ws As Worksheet

    Application.ScreenUpdating = False
    Sheets("Summary").Select
    Set Wb = ActiveWorkbook
    'Column D = all part numbers
    'Column E = unique part numbers
    With Columns("D:E")
        .EntireColumn.Insert
    End With
    Range("D1:E1") = "Part Number"
    For Each Ws In Wb.Worksheets
        If Ws.Name <> "Summary" Then
            lngSummaryLastRow = Sheets("Summary").Range("D" & Rows.Count).End(xlUp).Row + 1
            lngWsLastRow = Sheets(Ws.Name).Range("A" & Rows.Count).End(xlUp).Row
            Sheets(Ws.Name).Range("A2:A" & lngWsLastRow).Copy Sheets("Summary").Range("D" & lngSummaryLastRow)
        End If
    Next Ws
    lngSummaryLastRow = Sheets("Summary").Range("D" & Rows.Count).End(xlUp).Row
    Range("D1:D" & lngSummaryLastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1:E" & lngSummaryLastRow), Unique:=True
    lngSummaryLastRow = Sheets("Summary").Range("E" & Rows.Count).End(xlUp).Row
    With Range("E2:E" & lngSummaryLastRow)
        .Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        .Copy Range("A2")
        Application.CutCopyMode = False
    End With
    With Range("E1:E" & lngSummaryLastRow)
        .ClearContents
    End With
    lngSummaryLastRow = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
    lngWsLastRow = Sheets("Summary").Range("D" & Rows.Count).End(xlUp).Row
    With Range("B2:B" & lngSummaryLastRow)
        .FormulaR1C1 = "=COUNTIF(R2C4:R" & lngWsLastRow & "C4,RC[-1])"
        .Copy
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End With
    With Columns("D:E")
        .EntireColumn.Delete
    End With
    Range("C1").Select
    Application.ScreenUpdating = True
End Sub

Please TEST this FIRST in a COPY of your workbook.

Then run the 'CountDuplicatePartNumbers' macro.

Have a great day,
Stan

 

[jindon]

Only count?

Sub test()
Dim ws As Worksheet, a, i As Long, b(), n As Long, x As Long
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Summary").Delete
Application.DisplayAlerts = True
Sheets.Add.Name = "Summary"
ReDim b(1 To Rows.Count, 1 To 3)
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For Each ws In Worksheets
         If ws.Name <> "Summary" Then
              a = ws.Range("a1").CurrentRegion.Resize(,2).Value
              For i = 2 To UBound(a,1)
                   If Not .exists(a(i,1)) Then
                        n = n + 1 : b(n,1) = a(i,1)
                        .add a(i,1), n
                   End If
                   x = .item(a(i,1))
                   b(x,2) = b(x,2) + 1 : b(x,3) = b(x,3) + a(i,2)
               Next
          End If
     Next
End With
With Sheets("Summary")
     .Range("a1").Resize(,3).Value = [{"Part#","Appearance","Total"}]
     .Range("b1").Resize(n,3).Value = b
End With
End Sub

 

[facethegod]

Try this maybe....?

Option Explicit
Public Sub femi()
Dim i, j, Lrow As Double
Dim ar(), ar1(), fo As Variant
Dim cell, c As Range
Dim wk As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
ReDim Preserve ar1(1 To Rows.Count, 1 To 2)
For Each wk In Worksheets
If wk.Name <> "Summary" Then
wk.Activate
Range("A:A").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("A:A"), CopyToRange:=[B1], Unique:=True
Lrow = Cells(Rows.Count, 2).End(xlUp).Row
    For Each cell In Range("B2:B" & Lrow)
        i = i + cell.Count
        ReDim Preserve ar(1 To i)
        ar(i) = cell
        Set c = Range("A:A").Find(ar(i), LookIn:=xlValues)
        If c Is Nothing Then Exit For
        c.Select
        Do Until c.Address = fo
        j = j + 1
        Range("A:A").FindNext(After:=ActiveCell).Select
        fo = ActiveCell.Address
        Loop
        ar1(i, 1) = ar(i)
        ar1(i, 2) = j
        Sheets("Summary").Cells(i, 1) = ar(i)
        Sheets("Summary").Cells(i, 2) = j
        j = 0
    Next
Columns("B:B").ClearContents
End If
Next
Sheets("Summary").Activate
Range("1:1").Insert Shift:=xlDown
Range("a1").Resize(1, 2).Value = [{"Part#","Qty"}]
Range("A:A").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("A:A"), CopyToRange:=[C1], Unique:=True
Lrow = Cells(Rows.Count, 3).End(xlUp).Row
Range("D2").Formula = "=Sumif(A:A,C2,B:B)"
Range("D2").Resize(Lrow - 1, 1).FillDown
Columns("D:D").Copy
Columns("D:D").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Columns("A:B").Delete
Range("a1").Resize(1, 2).Value = [{"Part#","Qty"}]
Application.ScreenUpdating = True
End Sub

HTH