历遍工作表填充列数据的问题

杨小妹

附件 历遍工作表填充列数据附件.rar (743.35 KB, 下载次数: 13)

2024-7-24 07:26 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.24
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("Sheet0")
   
4.     With sh
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         c = .Range("XFD1").End(1).Column
   
7.         arr = .[a1].Resize(r, c)
   
8.     End With
   
9.     On Error Resume Next
   
10.     For j = 6 To UBound(arr, 2)
    
11.         n = n + 1
    
12.         ReDim brr(1 To UBound(arr), 1 To 4)
    
13.         m = 0
    
14.         For i = 1 To UBound(arr)
    
15.             m = m + 1
    
16.             brr(m, 1) = arr(i, 1)
    
17.             brr(m, 2) = arr(i, 2)
    
18.             brr(m, 3) = arr(i, j)
    
19.             brr(m, 4) = arr(i, 4)
    
20.         Next
    
21.         With Sheets("Sheet" & n)
    
22.             .UsedRange.ClearContents
    
23.             .[a1].Resize(m, 4) = brr
    
24.         End With
    
25.     Next
    
26.     Application.ScreenUpdating = True
    
27.     MsgBox "OK！"
    
28. End Sub
    
29. 
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, i&
   
    Application.ScreenUpdating = False
   
    With Worksheets(1)
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        ar = .Range("A1:I" & r).Value
    End With
   
    For j = 6 To 9
        For i = 1 To UBound(ar)
            ar(i, 3) = ar(i, j)
        Next i
        With Worksheets(j - 4)
            .[A1].Resize(UBound(ar), 4) = ar
        End With
    Next j
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

.............

一招秒杀

这么简单的破事，复制粘贴几下不就全部搞完了吗？ 你们还写这么多代码，真是闲的蛋疼，这智商让人担忧着急啊。

ykcbf1100

一招秒杀 发表于 2024-7-25 23:16
这么简单的破事，复制粘贴几下不就全部搞完了吗？ 你们还写这么多代码，真是闲的蛋疼，这智商让人担忧着急 ...

一招哥，这么闲吗？世界那么大，你应该去看看，顺便指点辅导一下那些世界上的大师。