代码错误，求修改

施学明

Sub SplitDataIntoNewWorkbooks()

   Dim wbSource As Workbook

   Dim wsSource As Worksheet

   Dim wbTarget As Workbook

   Dim wsTarget As Worksheet

   Dim lastRow As Long

   Dim rowCounter As Long

   Dim fileCounter As Long

   Dim targetRow As Long

   Dim dateStr As String

   Dim targetName As String

   

    '设置源工作簿和工作表

   Set wbSource = Workbooks("批量下拨20240731")

   Set wsSource = wbSource.Sheets("批量下拨")

   

    '获取源工作表中的最后一行

   lastRow = wsSource.Cells(wsSource.Rows.Count,"A").End(xlUp).Row

   

    '初始化计数器

   fileCounter = 1

   rowCounter = 1

   targetRow = 2

   

    '获取当前日期字符串

   dateStr = Format(Now, "yyyy-mm-dd")

   

    '循环处理数据，每20行创建一个新工作簿

   Do While rowCounter <= lastRow

       ' 创建新工作簿

       Set wbTarget = Workbooks.Add

       Set wsTarget = wbTarget.Sheets(1)

      

       ' 设置新工作簿的名称为当前日期加上序号

       targetName = "批量下拨_" & dateStr & "_" & fileCounter &".xlsx"

       wbTarget.SaveAs Filename:=ThisWorkbook.Path& "\\" & targetName

        

       ' 复制第一行到新工作簿

       wsSource.Rows(1).Copy Destination:=wsTarget.Rows(1)

      

       ' 复制后续的20行数据到新工作簿

       wsSource.Range(wsSource.Cells(rowCounter, 1), wsSource.Cells(rowCounter+ 19, wsSource.Columns.Count)).Copy _

           Destination:=wsTarget.Range(wsTarget.Cells(targetRow, 1))

      

       ' 更新计数器和行号

       rowCounter = rowCounter + 20

       targetRow = targetRow + 20

       fileCounter = fileCounter + 1

   Loop

   

    '如果最后一组数据不足20行，也需要复制

   If rowCounter - 20 < lastRow Then

       Set wbTarget = Workbooks.Add

       Set wsTarget = wbTarget.Sheets(1)

      

       ' 设置新工作簿的名称为当前日期加上序号

       targetName = "批量下拨_" & dateStr & "_" & fileCounter &".xlsx"

       wbTarget.SaveAs Filename:=ThisWorkbook.Path & "\\" &targetName

      

       ' 复制第一行到新工作簿

       wsSource.Rows(1).Copy Destination:=wsTarget.Rows(1)

      

       ' 复制剩余的数据到新工作簿

       wsSource.Range(wsSource.Cells(rowCounter - 20, 1),wsSource.Cells(lastRow, wsSource.Columns.Count)).Copy _

           Destination:=wsTarget.Range(wsTarget.Cells(targetRow, 1))

   End If

   

    '清理

   Set wsSource = Nothing

   Set wsTarget = Nothing

   Set wbTarget = Nothing

   Set wbSource = Nothing

End Sub

施学明

运行错误，请高手相助

peteryhr

Destination:=wsTarget.Range(wsTarget.Cells(targetRow, 1))换成Destination:=wsTarget.Cells(targetRow, 1)试一下。但是结果表好像怪怪的

边缘码农

没说是什么错误。
另外：

这个地方感觉奇怪，没有附件，不能测试。

心的启点

边缘码农 发表于 2024-8-1 15:11
没说是什么错误。
另外：

这个应该是正解

施学明

运行错误1004，无法访问文件

边缘码农

施学明 发表于 2024-8-1 15:14
运行错误1004，无法访问文件

看4楼，去掉一个斜杠试试。

施学明

上传了附件的

边缘码农

施学明 发表于 2024-8-1 15:16
上传了附件的

不好意思，我的问题，没注意到。

边缘码农

经测试附件，发现还是有些问题。