CODEWITHSUNDEEP
vbaexcel
Dyhouse
Dyhouse

Reputation: 83

Count the number of sheets in a separate workbook and return to a cell in original workbook

I have written a query that opens a separate file, counts all the unique 13 digit values, and copies all of the data related to that no. into separate sheets in a new workbook. What I now need to do is, from the original workbook where the macro lives, count all of the the sheets in the new workbook and return the count to a cell in the original workbook. For some reason, this baffling me so any assistance would be greatly appreciated. 

Option Explicit

Sub MPANSeparation()

Dim X As Integer               'Holds Count of rows
Dim Y As Integer            'Holds the count of copied cells
Dim MyLimit As Long         'Holds the count of matches
Dim MyTemp As String          'Holds the MPAN #
Dim MyNewBook As String     'Holds the name of the new workbook
Dim FullFileName As String  'Holds the full file name
Dim FileLocation As String  'Holds the file location
Dim FileName As String      'Holds the file name
Dim MPANSeparate As Excel.Workbook
Dim NumberOfSheets As Double

'Turn Off Screen Updates
Application.ScreenUpdating = False
'Turn off calculations
Application.Calculation = xlCalculationManual

'Identifies cell references for upload file
FullFileName = Sheet1.Cells(7, 2)
FileLocation = Sheet1.Cells(8, 2)
FileName = Sheet1.Cells(9, 2)

'Identifies workbook where data is being extracted from.
 Application.EnableEvents = False
Application.DisplayAlerts = False
Set MPANSeparate = Workbooks.Open(FullFileName, ReadOnly:=False)

'Ensure we're on the data sheet
Sheets("Sheet1").Select

'Get the count of the rows in the current region
X = Range("A1").CurrentRegion.Rows.Count


'Add a new "Scratch" Sheet after first sheet
Sheets.Add After:=Sheets(1)
'Rename newly added sheet
ActiveSheet.Name = "Scratch"

'Copy all of column A of the first sheet to scratch
Sheets(1).Range("A1:A" & X).Copy Sheets("Scratch").Range("A1")

'Copy all of column B of the first sheet to scratch
Sheets(1).Range("B1:B" & X).Copy 
Sheets("Scratch").Range("A1048575").End(xlUp).Offset(1, 0)

'Copy all of column C of the first sheet to scratch
Sheets(1).Range("C1:C" & X).Copy 
Sheets("Scratch").Range("A1048575").End(xlUp).Offset(1, 0)


'Remove all duplicates
ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=1, Header:= _
    xlYes

'Select start of range
Range("A1").Select

'Loop to test for len of 13 characters
Do While ActiveCell.Value <> ""
    'Logical test (is this cell 13 characters long)
    If Len(ActiveCell.Value) <> 13 Then
        'Delete the whole row
        ActiveCell.EntireRow.Delete
    Else
        'Move down a cell
        ActiveCell.Offset(1, 0).Select
    End If
Loop

'Add CountIf formulas to column B (checking A,B & C)
Range("B1:B" & Range("A1048575").End(xlUp).Row) _
    .Formula = "=COUNTIF(Sheet1!C[-1]:C[1],Scratch!RC[-1])"

'Add a new workbook
Workbooks.Add
'Get the name of the new workbook
MyNewBook = ActiveWorkbook.Name

'Go back to this workbook
MPANSeparate.Activate

'Select start of range
Range("A1").Select

'Loop to add sheets (one for each MPAN)
Do While ActiveCell.Value <> ""
    'Get MPAN #
    MyTemp = ActiveCell.Value
    'Add new sheet to "MyNewBook"
    Workbooks(MyNewBook).Sheets.Add _

After:=Workbooks(MyNewBook).Sheets(Workbooks(MyNewBook).Sheets.Count)
    'Rename newly added sheet to MPAN #
    Workbooks(MyNewBook).Sheets(Workbooks(MyNewBook).Sheets.Count).Name = 
MyTemp
    'Move down a cell
    ActiveCell.Offset(1, 0).Select
Loop

'Select start of range
Range("A1").Select


'The outer copy and paste loop
Do While ActiveCell.Value <> ""

    'Select start of range
    Range("A1").Select

    'Get the first value we're looking for
    MyTemp = ActiveCell.Value
    'Get the actual count of matches
    MyLimit = ActiveCell.Offset(0, 1).Value


    'Go to the data sheet
    Sheets("Sheet1").Select

    'The A loop
    'Select start of range
    Range("A1").Select

        Do While ActiveCell.Value <> ""
            If ActiveCell.Value <> MyTemp Then
                'Move down a cell
                ActiveCell.Offset(1, 0).Select
            Else
                'Copy the entire row to the appropriate sheet in the new 
Workbook
                ActiveCell.EntireRow.Copy _

Workbooks(MyNewBook).Sheets(MyTemp).Range("A1048575").End(xlUp).Offset(1, 0)

                'Move down a cell
                ActiveCell.Offset(1, 0).Select

                'Increase Y by 1
                Y = Y + 1

                'If we have all the matches, add headings and go to 
NextOuterLoop
                If Y = MyLimit Then
                    Range("A1").EntireRow.Copy 
Workbooks(MyNewBook).Sheets(MyTemp).Range("A1")
                    GoTo NextOuterLoop
                End If
            End If
        Loop

    'The B loop
    'Select start of range
    Range("B1").Select

        Do While ActiveCell.Value <> ""
            If ActiveCell.Value <> MyTemp Then
                'Move down a cell
                ActiveCell.Offset(1, 0).Select
            Else
                'Copy the entire row to the appropriate sheet in the new 
Workbook
                ActiveCell.EntireRow.Copy _

Workbooks(MyNewBook).Sheets(MyTemp).Range("A1048575").End(xlUp).Offset(1, 0)

                'Move down a cell
                ActiveCell.Offset(1, 0).Select

                'Increase Y by 1
                Y = Y + 1

                'If we have all the matches, add headings and go to 
NextOuterLoop
                If Y = MyLimit Then
                    Range("A1").EntireRow.Copy 
Workbooks(MyNewBook).Sheets(MyTemp).Range("A1")
                    GoTo NextOuterLoop
                End If
            End If
        Loop


    'The C loop
    'Select start of range
    Range("C1").Select

        Do While ActiveCell.Value <> ""
            If ActiveCell.Value <> MyTemp Then
                'Move down a cell
                ActiveCell.Offset(1, 0).Select
            Else
                'Copy the entire row to the appropriate sheet in the new 
Workbook
                ActiveCell.EntireRow.Copy _

Workbooks(MyNewBook).Sheets(MyTemp).Range("A1048575").End(xlUp).Offset(1, 0)

                'Move down a cell
                ActiveCell.Offset(1, 0).Select

                'Increase Y by 1
                Y = Y + 1

                'If we have all the matches, add headings and go to 
NextOuterLoop
                If Y = MyLimit Then
                    Range("A1").EntireRow.Copy 
Workbooks(MyNewBook).Sheets(MyTemp).Range("A1")
                    GoTo NextOuterLoop
                End If
            End If
        Loop

NextOuterLoop:

    'Reset Y
    Y = 0
    'Go to the scratch sheet
    Sheets("Scratch").Select
    'Delete the entire row
    Range("A1").EntireRow.Delete

Loop

'Turn off display alerts
Application.DisplayAlerts = False
'Delete the scratch sheet
Sheets("Scratch").Delete
'Turn on display alerts
Application.DisplayAlerts = True

Workbooks(MyNewBook).SaveAs ("C:\Users\XNEID\Desktop\Test MPAN Destination 
Folder\Shell_MPANs_Test1" & ".xlsx")


'Ensure we're back on the data sheet
Sheets("Sheet1").Select
'Select start of range
Range("A1").Select

Call forEachWs
'Turn On Calculations
Application.Calculation = xlCalculationAutomatic
'Turn on screen updates
Application.ScreenUpdating = True

End Sub

Sub forEachWs()
Dim ws As Worksheet

'Opens new workbook for formatting
Workbooks.Open "C:\Users\XNEID\Desktop\Test MPAN Destination 
Folder\Shell_MPANs_Test1.xlsx"

For Each ws In ActiveWorkbook.Worksheets
Call resizingColumns(ws)
Next
End Sub

Sub resizingColumns(ws As Worksheet)
With ws
    .Range("A1:BB1").EntireColumn.AutoFit
End With

NumberOfSheets = Workbooks(FileName).Worksheets.Count


End Sub

Upvotes: 0

Views: 854

Answers (1)

Rik Sportel
Rik Sportel

Reputation: 2679

The following script opens a workbook and returns the count of sheets in Range A1 in the first sheet of the workbook the macro resides in:

Sub Test()
Dim fullPath As String
Dim wb As Workbook

fullPath = "Somepath\someworkbook.xlsx"

Set wb = Workbooks.Open(fullPath)

ThisWorkbook.Worksheets(1).Range("A1").Value = wb.Worksheets.Count

wb.Close

Set wb = Nothing
End Sub

Upvotes: 1

Related Questions