老师们好！VBA提取和排列，请各位老师帮忙看看。谢谢！！

13602822168

老师们好！VBA提取和排列，请各位老师帮忙看看。谢谢！！

二个区域都要。

清风竹-

Sub 提取和排列()
mrr = Sheet1.UsedRange
m = UBound(mrr)
arr = Sheet1.Range("t16:ax" & m)
ReDim brr(1 To UBound(arr), 1 To 20)
ReDim brr2(1 To UBound(arr), 1 To 20)
For i = 1 To UBound(arr)
   l = 0
     For j = 1 To UBound(arr, 2)

         If arr(i, j) <> "" Then
             l = l + 1
             If l = 1 Then n = n + 1
             brr(i, l) = arr(i, j)
             brr2(n, l) = arr(i, j)
         End If
       Next
Next
Range("az16").Resize(UBound(arr), 20) = brr
Range("bu16").Resize(UBound(arr), 20) = brr2
End Sub

gwjkkkkk

Option Explicit
Sub TEST3()
    Dim ar, br, i&, j&, r&, n&, iColSize&, t#, Rng As Range, strJoin$
   
    Application.ScreenUpdating = False
    t = Timer
   
    Set Rng = Intersect(Rows("16:" & Rows.Count), Columns("T:AX"))
    ar = Intersect(ActiveSheet.UsedRange, Rng).Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    ReDim cr(1 To UBound(ar), 1 To UBound(ar, 2))
   
    For i = 1 To UBound(ar)
        strJoin = Join(Application.Index(ar, i), "")
        If strJoin <> "" Then
            n = 0: r = r + 1
            For j = 1 To UBound(ar, 2)
                If Len(ar(i, j)) Then
                    n = n + 1
                    br(i, n) = ar(i, j)
                    cr(r, n) = ar(i, j)
                End If
            Next j
            If n > iColSize Then iColSize = n
        End If
    Next i
        
    [AZ16].Resize(UBound(br), iColSize) = br
    [BU16].Resize(r, iColSize) = cr
   
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

。。。。。。。。。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%, c%, j%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         r = .Columns("t:ax").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
6.         arr = .Range("t16:ax" & r)
   
7.         ReDim brr(1 To UBound(arr), 1 To 20)
   
8.         For i = 1 To UBound(arr)
   
9.             n = 0
   
10.             For j = 1 To UBound(arr, 2)
    
11.                 If Len(arr(i, j)) <> 0 Then
    
12.                     n = n + 1
    
13.                     brr(i, n) = arr(i, j)
    
14.                 End If
    
15.             Next
    
16.         Next
    
17.         .Range("az16").Resize(UBound(brr), UBound(brr, 2)) = brr
    
18.         ReDim crr(1 To UBound(brr), 1 To 20)
    
19.         m = 0
    
20.         For i = 1 To UBound(brr)
    
21.             If Len(brr(i, 1)) <> 0 Then
    
22.                 m = m + 1
    
23.                 For j = 1 To UBound(brr, 2)
    
24.                     If Len(brr(i, j)) = 0 Then
    
25.                         Exit For
    
26.                     End If
    
27.                     crr(m, j) = brr(i, j)
    
28.                 Next
    
29.             End If
    
30.         Next
    
31.         .Range("bu16").Resize(UBound(crr), UBound(crr, 2)) = crr
    
32.     End With
    
33. End Sub
    

复制代码

chxw68

参与一下。

13602822168

chxw68 发表于 2024-8-25 11:47
参与一下。

非常感谢！！模块如何应用到其他页面？