別のブック内のシート数をカウントし、元のブック内のセルに戻る

Question

別のファイルを開き、すべての一意の13桁の値をカウントし、そのnoに関連するすべてのデータをコピーするクエリを作成しました。新しいワークブックの別のシートに追加します。私が今必要とするのは、マクロが存在する元のブックから、新しいブックのすべてのシートを数え、元のブックのセルにカウントを戻すことです。何らかの理由で、これは私を困らせるので、どんな支援も大歓迎です。

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