[已解决]如何能做到

mmc998

工作簿1.rar (18.72 KB, 下载次数: 7)

2021-3-11 08:55 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-3-11 15:58

Sub demo()
   s = 1
   For i = 9 To [a65536].End(xlUp).Row
      If Sheets(1).Cells(i, 1) Then
         r = r + 1
         If r = 3 Then
            If c = 0 Then
               s = s + 1
               Sheets.Add(after:=Sheets(Worksheets.Count)).Name = "Sheet" & s
               t = 5
            End If
            arr = Application.Transpose(Sheets(1).Cells(i - 2, 1).Resize(3, 10))
            Cells(1, t).Resize(10, 3) = arr
            r = 0: c = c + 1: t = t + 4
            If c = 10 Then c = 0
         End If
      End If
   Next
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

Sub demo()
   s = 1
   For i = 9 To [a65536].End(xlUp).Row
      If Sheets(1).Cells(i, 1) Then
         r = r + 1
         If r = 3 Then
            If c = 0 Then
               s = s + 1
               Sheets.Add(after:=Sheets(Worksheets.Count)).Name = "Sheet" & s
               t = 5
            End If
            arr = Application.Transpose(Sheets(1).Cells(i - 2, 1).Resize(3, 10))
            Cells(1, t).Resize(10, 3) = arr
            r = 0: c = c + 1: t = t + 4
            If c = 10 Then c = 0
         End If
      End If
   Next
End Sub

祝順心，南無阿彌陀佛！

mmc998

cutecpu 发表于 2021-3-11 15:58
Sub demo()
   s = 1
   For i = 9 To [a65536].End(xlUp).Row

每100个一组，怎么写？

cutecpu

mmc998 发表于 2021-3-11 20:18
每100个一组，怎么写？

If c = 10 Then c = 0改成
If c = 100 Then c = 0



祝順心，南無阿彌陀佛！

mmc998

cutecpu 发表于 2021-3-11 20:41
If c = 10 Then c = 0改成
If c = 100 Then c = 0

4列8行的数据怎么做？

cutecpu

mmc998 发表于 2021-3-12 07:03
4列8行的数据怎么做？

您好，可以上傳附件舉例一下嗎

mmc998

工作簿1.rar (36.8 KB, 下载次数: 1)

2021-3-12 09:50 上传

点击文件名下载附件

cutecpu

mmc998 发表于 2021-3-12 09:50

Sub demo()
   Row = 4 '定義列數
   col = 8 '定義行數
   Group = 100 ' 定義幾個一組
   s = 1
   For i = 11 To [a65536].End(xlUp).Row
      If Sheets(1).Cells(i, 1) Then
         r = r + 1
         If r = Row Then
            If c = 0 Then
               s = s + 1
               Sheets.Add(after:=Sheets(Worksheets.Count)).Name = "Sheet" & s
               t = 5
            End If
            arr = Application.Transpose(Sheets(1).Cells(i - Row + 1, 1).Resize(Row, col))
            Cells(1, t).Resize(col, Row) = arr
            r = 0: c = c + 1: t = t + Row + 1
            If c = Group Then c = 0
         End If
      End If
   Next
End Sub

祝順心，南無阿彌陀佛！