求大神指点一个循环插入复制粘贴宏，谢谢

cadunion

原表

原表如上图
只是举例子弄了3行
其实大概有800多行
中间还有空行
想做成下面的这种效果

想得到的表

800多行手动太悲剧了
求大神指点一个循环插入复制粘贴宏，谢谢！

cadunion

横向数据全部插入到F列并且不能覆盖，ABCDE列都有数据也不能错行

cadunion

测试工作簿1.zip (10.87 KB, 下载次数: 3)

2019-9-28 12:18 上传

点击文件名下载附件

cadunion

Sheet1原表
Sheet1（2）改以后的

cadunion

在线等 挺急的

cadunion

大神都放假了么 我还在苦逼加班。。。。。。

达win

1. Sub Main()
   
2.     Application.DisplayAlerts = False
   
3.     ThisWorkbook.Save
   
4.     Application.DisplayAlerts = True
   
5.     Dim arr, brr(1 To 10 ^ 5, 1 To 14)
   
6.     Dim i As Long, j As Long, k As Long, p As Integer
   
7.     arr = Sheet3.Range("A1").CurrentRegion
   
8.     For i = 2 To UBound(arr)
   
9.         For j = 7 To UBound(arr, 2)
   
10.             k = k + 1
    
11.             For p = 1 To 6
    
12.                 brr(k, p) = arr(i, p)
    
13.             Next
    
14.             brr(k, 7) = arr(i, j)
    
15.         Next
    
16.     Next
    
17.     If k > 1 Then
    
18.       Sheet4.Range("A2").Resize(k, 14) = brr
    
19.     End If
    
20. End Sub

复制代码

达win

看看是不是这样 O(∩_∩)O

cadunion

达win 发表于 2019-9-28 15:02
看看是不是这样 O(∩_∩)O

感谢法神，可以实现了 就是还需要麻烦大神指点一下
能够给个注释让我学习一下  谢谢了


Sub Main()
    Application.DisplayAlerts = False
    ThisWorkbook.Save
    Application.DisplayAlerts = True
    Dim arr, brr(1 To 10 ^ 5, 1 To 14)
    Dim i As Long, j As Long, k As Long, p As Integer
    arr = Sheet3.Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
        For j = 7 To UBound(arr, 2)
            k = k + 1
            For p = 1 To 6
                brr(k, p) = arr(i, p)
            Next
            brr(k, 7) = arr(i, j)
        Next
    Next
    If k > 1 Then
      Sheet4.Range("A2").Resize(k, 14) = brr
    End If
End Sub

cadunion

达win 发表于 2019-9-28 15:02
看看是不是这样 O(∩_∩)O

复制到我自己的表里就提示错误 变量未定义
Sub Main()是黄色的