[已解决]单元格增加了六列，按需复制代码不会更改，帮忙下！

zames

如文档所示，一个是原文档，只按需复制2列的内容，增加了6列，等于要按需复制8列内容，VBA代码不会改了，懂的帮帮忙，谢谢！
已有大神帮忙写了代码，见文档 TEST_01 ,应用进去出现类型匹配提示，输入的数据变更，有时候还会出现错误代码13，有大神帮忙看看，谢谢

最佳答案

月排行榜 / 总排行榜

excel用账户

2022-8-22 09:45

Sub demo()
   [a2:H10000].ClearContents
   b = Range("j2:r" & [r2].End(4).Row)
   r = 1
   For i = 1 To UBound(b)
      If b(i, 9) > 0 Then
        For j = 1 To b(i, 9)
           r = r + 1
           For k = 1 To 8
            Cells(r, k) = b(i, k)
           Next
        Next
      End If
   Next
End Sub

跳转到最佳答案楼层

excel用账户

可以举个例子要做成什么样的效果吗

excel用账户

Sub demo()
   [a2:H10000].ClearContents
   b = Range("j2:r" & [r2].End(4).Row)
   r = 1
   For i = 1 To UBound(b)
      If b(i, 9) > 0 Then
        For j = 1 To b(i, 9)
           r = r + 1
           For k = 1 To 8
            Cells(r, k) = b(i, k)
           Next
        Next
      End If
   Next
End Sub

zames

excel用账户 发表于 2022-8-22 09:45
Sub demo()
   [a2:H10000].ClearContents
   b = Range("j2:r" & [r2].End(4).Row)

点击 COPY 控件，有时候会出现错误类型布匹配错误和错误代码13，帮忙再看看，谢谢！

哥儿-

[r2].End(4).Row-----取值到合计3549，row等于24，不需要循环到这行。
b(i, 9) > 0 ------空单元格为假空，所以判断的时候是大于零，所以循环出错。
Sub demo()
   [a2:H10000].ClearContents
   b = Range("j2:r" & [j2].End(4).Row)
   r = 1
   For i = 1 To UBound(b)
      If b(i, 9) <> "" Then
        For j = 1 To b(i, 9)
           r = r + 1
           For k = 1 To 8
            Cells(r, k) = b(i, k)
           Next
        Next
      End If
   Next
End Sub

zames

哥儿- 发表于 2022-8-22 15:06
[r2].End(4).Row-----取值到合计3549，row等于24，不需要循环到这行。
b(i, 9) > 0 ------空单元格为假空 ...

谢谢老师！我那个R列数值把空值改为0就不会出错了