シートをサブスタンダードにインポートするためのサブプロシージャ

Question

このコードは一度は動作しますが、動作していない最後の数日間です。アクティブワークブック1からThisWorkbook2にシートをインポートすると仮定します。

Sub ImportallWBsh() 

    'https://michaelaustinfu.files.wordpress.com/2013/03/excel-vba-for-dummies-3rd-edition.pdf, Page 245 
    Dim Finfo As String 
    Dim FilterIndex As Integer 
    Dim Title As String 
    Dim Filename As Variant 
    Dim wb As Workbook 


    'Setup the list of file filters 
    Finfo = "Excel Files (*.xlsx),*xlsx," 

    'Display *.* by default 
    FilterIndex = 1 

    'Set the dialog box caption 
    Title = "Select a File to Import" 

    'Get the Filename 
    Filename = Application.GetOpenFilename(Finfo, _ 
     FilterIndex, Title) 

    'Handle return info from dialog box 
    If Filename = False Then 
     MsgBox "No file was selected." 
    Else 
     MsgBox "You selected " & Filename 
    End If 

    On Error Resume Next 

    Set wb = Workbooks.Open(Filename) 



    FilenameWorkbook.Sheets.Copy _ 
     After:=ThisWorkbook.Sheets("Sheet3") 

    wb.Close True 

    ThisWorkbook.Sheets("Sheet1").Select 

End Sub 

あなたは何が間違っているかも知っていますか？あなたは間違ってSetを使用している

は...あなたは

Answer 1

あなたは夫婦の問題が起こって持っていただきありがとうございます。 GetOpenFileNameは文字列を返します。 Workbooks.Openはオブジェクトを返します。 thisを確認してください。読むことができるあなたの最初のセクション：

s = Application.GetOpenFilename() 
Set Wb1 = Workbooks.Open (s) 

あなたはまた、二回ワークブックsを開いている、プラスは、Excelの新しいインスタンスを作成し、オブジェクトobjexcelを作成していますが、Set objexcel = Nothingでそれを閉じていないので、毎回コードを実行すると、別のExcelのコピーがバックグラウンドで開かれます。

（クローズExcelは、その後、CTRL + ALT + DELは、あなたのタスクマネージャをチェックすると、私はあなたが私が何を意味するかわかります賭ける！）私はあなたがthis searchを試してみてください示唆して

を開始するには、 thisやthisなど、他の人のために働いた同じ質問に対するいくつかの解決策が表示されます。

Answer 2

このようなものは、あなたのために仕事をする必要があります。

Sub Basic_Example_1() 
    Dim MyPath As String, FilesInPath As String 
    Dim MyFiles() As String 
    Dim SourceRcount As Long, Fnum As Long 
    Dim mybook As Workbook, BaseWks As Worksheet 
    Dim sourceRange As Range, destrange As Range 
    Dim rnum As Long, CalcMode As Long 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    'Add a slash at the end if the user forget it 
    If Right(MyPath, 1) <> "\" Then 
     MyPath = MyPath & "\" 
    End If 

    'If there are no Excel files in the folder exit the sub 
    FilesInPath = Dir(MyPath & "*.xl*") 
    If FilesInPath = "" Then 
     MsgBox "No files found" 
     Exit Sub 
    End If 

    'Fill the array(myFiles)with the list of Excel files in the folder 
    Fnum = 0 
    Do While FilesInPath <> "" 
     Fnum = Fnum + 1 
     ReDim Preserve MyFiles(1 To Fnum) 
     MyFiles(Fnum) = FilesInPath 
     FilesInPath = Dir() 
    Loop 

    'Change ScreenUpdating, Calculation and EnableEvents 
    With Application 
     CalcMode = .Calculation 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    'Add a new workbook with one sheet 
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
    rnum = 1 

    'Loop through all files in the array(myFiles) 
    If Fnum > 0 Then 
     For Fnum = LBound(MyFiles) To UBound(MyFiles) 
      Set mybook = Nothing 
      On Error Resume Next 
      Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 

       On Error Resume Next 

       With mybook.Worksheets(1) 
        Set sourceRange = .Range("A1:C1") 
       End With 

       If Err.Number > 0 Then 
        Err.Clear 
        Set sourceRange = Nothing 
       Else 
        'if SourceRange use all columns then skip this file 
        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then 
         Set sourceRange = Nothing 
        End If 
       End If 
       On Error GoTo 0 

       If Not sourceRange Is Nothing Then 

        SourceRcount = sourceRange.Rows.Count 

        If rnum + SourceRcount >= BaseWks.Rows.Count Then 
         MsgBox "Sorry there are not enough rows in the sheet" 
         BaseWks.Columns.AutoFit 
         mybook.Close savechanges:=False 
         GoTo ExitTheSub 
        Else 

         'Copy the file name in column A 
         With sourceRange 
          BaseWks.cells(rnum, "A"). _ 
            Resize(.Rows.Count).Value = MyFiles(Fnum) 
         End With 

         'Set the destrange 
         Set destrange = BaseWks.Range("B" & rnum) 

         'we copy the values from the sourceRange to the destrange 
         With sourceRange 
          Set destrange = destrange. _ 
              Resize(.Rows.Count, .Columns.Count) 
         End With 
         destrange.Value = sourceRange.Value 

         rnum = rnum + SourceRcount 
        End If 
       End If 
       mybook.Close savechanges:=False 
      End If 

     Next Fnum 
     BaseWks.Columns.AutoFit 
    End If 

ExitTheSub: 
    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub 

https://www.rondebruin.nl/win/s3/win008.htm

Answer 3

正しい行のコードでは、する必要があります：

ActiveWorkbook.Sheets.Copy _ 
     After:=ThisWorkbook.Sheets("Hoja3") 

ので、コードが適切に機能します。ありがとうございます