计算单独工作簿中的工作表数量并返回到原始工作簿中的单元格
我写了一个查询，打开一个单独的文件，统计所有唯一的13位数字值，并复制所有与该数据相关的数据。 分成一个新的工作簿单独的工作表。 我现在需要做的是，从macros的原始工作簿中，计算新工作簿中的所有工作表，并将计数返回到原始工作簿中的单元格。 出于某种原因，这令我莫名其妙的任何援助将不胜感激。
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 以下脚本将打开一个工作簿并返回该macros驻留在工作簿的第一个工作表中的范围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