出力ファイルを元のワークブックと同じフォルダに保存する方法

Question

私は以下のようにVBAを持っています。これは、新しいExcelブックにモジュールを挿入するたびにVBAモジュールでのみ機能します。 Personal.xlsbに保存して、必要なときにいつでも実行したい。

出力ファイル（たとえば、データ1、データ2、データ3 ...データ99999）が元のブックと同じフォルダに保存されるように変更する方法を教えてください。

Sub SplitFixedRows() 
    Dim wb As Workbook 
    Dim ThisSheet As Worksheet 
    Dim NumOfColumns As Integer 
    Dim RangeToCopy As Range 
    Dim RangeOfHeader As Range   
    Dim WorkbookCounter As Integer 
    Dim RowsInFile  

    Application.ScreenUpdating = False 
    RowsInFile = InputBox("Please enter data size +1 header (Example: 11, 101, 501): ") 

    Set ThisSheet = ThisWorkbook.ActiveSheet 
    NumOfColumns = ThisSheet.UsedRange.Columns.Count 
    WorkbookCounter = 1 

    Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns)) 
    For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1 
    Set wb = Workbooks.Add 

    RangeOfHeader.Copy wb.Sheets(1).Range("A1") 

    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns)) 
    RangeToCopy.Copy wb.Sheets(1).Range("A2") 

    wb.SaveAs ThisWorkbook.Path & "\Data" & WorkbookCounter 
    wb.Close 

    WorkbookCounter = WorkbookCounter + 1 
    Next p 

    Application.ScreenUpdating = True 
    Set wb = Nothing 
End Sub 

Answer 1

元のワークブックへの参照を保持する必要があります。次のコードでは、コードが開始するときにwbOrigをActiveWorkbookに設定してから、ThisWorkbookの代わりにそのオブジェクトを使用します。

Sub SplitFixedRows() 
    Dim wbOrig As Workbook 
    Dim wb As Workbook 
    Dim ThisSheet As Worksheet 
    Dim NumOfColumns As Integer 
    Dim RangeToCopy As Range 
    Dim RangeOfHeader As Range   
    Dim WorkbookCounter As Integer 
    Dim RowsInFile  

    Application.ScreenUpdating = False 
    RowsInFile = InputBox("Please enter data size +1 header (Example: 11, 101, 501): ") 

    Set wbOrig = ActiveWorkbook  
    Set ThisSheet = wbOrig.ActiveSheet 
    NumOfColumns = ThisSheet.UsedRange.Columns.Count 
    WorkbookCounter = 1 

    Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns)) 
    For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1 
    Set wb = Workbooks.Add 

    RangeOfHeader.Copy wb.Sheets(1).Range("A1") 

    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns)) 
    RangeToCopy.Copy wb.Sheets(1).Range("A2") 

    wb.SaveAs wbOrig.Path & "\Data" & WorkbookCounter 
    wb.Close 

    WorkbookCounter = WorkbookCounter + 1 
    Next p 

    Application.ScreenUpdating = True 
    Set wb = Nothing 
End Sub