我编写了一个查询，打开一个单独的文件，计算所有唯一的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
答案 0 :(得分：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