计算单独工作簿中的工作表数并返回到原始工作簿中的单元格

Question

我已经编写了一个查询来打开一个单独的文件，计算所有唯一的13位数字值并复制与该编号相关的所有数据。分成新的工作簿中的单独的工作表。我现在需要做的是，从宏的原始工作簿中，计算新工作簿中的所有工作表，并将计数返回到原始工作簿中的单元格。出于某种原因，这令我莫名其妙的任何援助将不胜感激。

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 

Answer 1

下面的脚本打开工作簿，并返回范围A1表的计数工作簿中的第一张宏所在：

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