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

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

1 个答案: