複数のタブをフォルダから1つのタブにコピーするときにVBA 1004エラーが発生する

Question

ワークブックページを1つのマスタードキュメントに結合しようとすると、1004エラーが発生します。コードはデバイス上で正しく動作しますが、友人デバイスでコードを実行しようとすると1004エラーが発生します。私は彼が2013年には優れていると信じています。私は2016年に秀でています。私のコードを両方のデバイスで使用できるものに変換する方法はありますか？

Sub CombineSheets() 
Dim sPath As String 
Dim sFname As String 
Dim wBk As Workbook 
Dim wSht As Variant 

Application.EnableEvents = False 
Application.ScreenUpdating = False 
sPath = InputBox("Enter a full path to workbooks") 
ChDir sPath 
sFname = InputBox("Enter a filename pattern") 
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) 
wSht = InputBox("Enter a worksheet name to copy") 
Do Until sFname = "" 
    Set wBk = Workbooks.Open(sFname) 
    Windows(sFname).Activate 
    Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1) 
    wBk.Close False 
    sFname = Dir() 
Loop 
ActiveWorkbook.Save 
Application.EnableEvents = True 
Application.ScreenUpdating = True 
End Sub 

私はそれを実行したときに、このフォルダの場所の入力を促し、正常に動作し、それが入力された特別ワークシート名から（通常*）からコピーし、コピーする必要があり、どのファイル尋ねます。

現実的には、数百個のExcelファイルから1つのワークシートを抽出し、1つのマスター文書に結合できるコードが必要です。どちらのワークシートを選ぶか選択することができます。

ありがとうございました！

Answer 1

マットのマグと同じように、実際に入力を検証する必要があります。

あなたの同僚はパスの最後に「\」を追加しましたか？パスは存在しますか？このようなもので、シートはあなたからコピーされたファイルに存在することを確実にする

テスト：

Function SheetExists(Name As String, Optional Workbook As Excel.Workbook = Nothing) As Boolean 
If Workbook Is Nothing Then Set Workbook = ThisWorkbook.Application.ActiveWorkbook 
On Error Resume Next 
    If Workbook.Worksheets(Name).Name <> vbNullString Then 
    End If 
    If Err.Number = 0 Then SheetExists = True 
On Error GoTo 0 
End Function 

ここでは述べ変更で、あなたのコードです：

Sub CombineSheets() 
Dim sPath As String 
Dim sFname As String 
Dim wBk As Workbook 
Dim sSht As String 

Application.EnableEvents = False 
Application.ScreenUpdating = False 
sPath = InputBox("Enter a full path to workbooks") 
'Use the FolderPicker to verify the path 
With Application.FileDialog(msoFileDialogFolderPicker) 
    If .Show Then sPath = .SelectedItems(1) 
End With 
'ChDir sPath 
sFname = InputBox("Enter a filename pattern") 
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) 
sSht = InputBox("Enter a worksheet name to copy") 
Do Until sFname = "" 
    Set wBk = Workbooks.Open(sFname) 
    'Windows(sFname).Activate 
    If SheetExists(sSht, wBk) Then 
     wBk.Sheets(sSht).Copy Before:=ThisWorkbook.Sheets(1) 
    End If 
    wBk.Close False 
    sFname = Dir() 
Loop 
'ActiveWorkbook.Save 
ThisWorkbook.Save 
Application.EnableEvents = True 
Application.ScreenUpdating = True 
End Sub 

大きな質問は、シートは同じサイズですか？古い.xlsファイルには65536行しかありません。2007年以降の.xlsxファイルは1048576行になります。

2つの異なるワークシートを混在させることはできません。その場合は、すべてのセルを1つのシートから別のシートにコピーする必要があります。

wBk.Sheets(sSht).Cells.Copy 
ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Sheets(1) 
ThisWorkbook.Sheets(1).Paste