这个怎么操作，具体见附件。

suxiong22

test.zip (85.92 KB, 下载次数: 20)

2018-9-1 21:48 上传

点击文件名下载附件

sheet1为原始数据，SHEET2为想要的结果。麻烦了。主要就是看用什么规律循环取数复制，我找不到规律，整晕了。如果太麻烦给个思路也行。

一把小刀闯天下

'你这数据本身就有问题，根据错误提示确认，，，

Option Explicit

Sub test()
  Dim i, arr, m, pos, p
  Application.ScreenUpdating = False
  On Error GoTo errmsg
  arr = Sheets("1").[a1].CurrentRegion.Offset(1)
  arr(UBound(arr, 1), 1) = "?"
  ReDim brr(1 To 17, 1 To 1), crr(1 To 17, 1 To 1)
  pos = 1: p = 2
  For i = 1 To UBound(arr, 1) - 1
    m = m + 1
    brr(m, 1) = arr(i, 2): crr(m, 1) = arr(i, 3)
    If Len(arr(i + 1, 1)) Then
      With Sheets("2")
        .Cells(4, p).Resize(UBound(brr)) = brr
        .Cells(22, p).Resize(UBound(brr)) = crr
        .Cells(41, p) = arr(pos, 1)
      End With
      m = 0: pos = i + 1: p = p + 3
      ReDim brr(1 To 17, 1 To 1), crr(1 To 17, 1 To 1)
    End If
  Next
  Application.ScreenUpdating = True
  Exit Sub
errmsg:
  Application.ScreenUpdating = True
  MsgBox "检查所示行数据块:" & i & vbNewLine & "单数据块最大支持17行！"
End Sub

suxiong22

一把小刀闯天下 发表于 2018-9-1 22:46
'你这数据本身就有问题，根据错误提示确认，，，

Option Explicit

test.zip (127.63 KB, 下载次数: 4)

2018-9-1 23:21 上传

点击文件名下载附件

已更新数据，数据，最大不超过17行，现在运行后部分填充过去了，但部分没有填充到SHEET2，需要把SHEET1的数据全部按规律填充到SHEET2，麻烦您。

一把小刀闯天下

'都输出了，只是输出表格格式还是有问题

'插入一个新工作表：sheet1,按我的方式给你输出

Option Explicit

Sub test()
  Dim i, arr, m, pos, p
  Application.ScreenUpdating = False
  On Error GoTo errmsg
  arr = Sheets("1").[a1].CurrentRegion.Offset(1)
  arr(UBound(arr, 1), 1) = "?"
  ReDim brr(1 To 17, 1 To 1), crr(1 To 17, 1 To 1)
  pos = 1: p = 2
  With Sheets("sheet1")
    .Cells.ClearContents
    For i = 1 To UBound(arr, 1) - 1
      m = m + 1
      brr(m, 1) = arr(i, 2): crr(m, 1) = arr(i, 3)
      If Len(arr(i + 1, 1)) Then
        .Cells(4, p).Resize(UBound(brr)) = brr
        .Cells(22, p).Resize(UBound(brr)) = crr
        .Cells(41, p) = arr(pos, 1)
        .Cells(1, p) = "保管期限"
        .Cells(3, p) = "个人编号"
        .Cells(21, p) = "姓名"
        .Cells(40, p) = "组号"
        m = 0: pos = i + 1: p = p + 2
        ReDim brr(1 To 17, 1 To 1), crr(1 To 17, 1 To 1)
      End If
    Next
    .Columns(1).Resize(, p).AutoFit
  End With
  Application.ScreenUpdating = True
  Exit Sub
errmsg:
  Application.ScreenUpdating = True
  MsgBox "检查是否存在:sheet1"
End Sub