如何将输出文件存储在与原始工作簿相同的文件夹中

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