求大神通过VBA代码操作实现时间对齐

vba韭菜

模板文件已上传，内有处理前原始工作表和处理后的实现效果工作表

蓝桥玄霜

对齐的例子：

3190496160

Sub 对齐()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim rn As Range
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("原始")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r < 2 Then MsgBox "原始表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
    Set rn = .Rows(1)
End With
With Sheets("实现效果")
    .UsedRange = Empty
    rn.Copy .[a1]
    n = 1
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            n = n + 1
            For j = 1 To 3
                .Cells(n, j) = ar(i, j)
            Next j
            d(ar(i, 1)) = n
        End If
    Next i
    For j = 4 To UBound(ar, 2) Step 3
        For i = 2 To UBound(ar)
            If ar(i, j) <> "" Then
                xh = d(ar(i, j))
                If xh <> "" Then
                    w = j - 1
                    For s = j To j + 2
                        w = w + 1
                        .Cells(xh, w) = ar(i, s)
                    Next s
                End If
            End If
        Next i
        k = .Cells(Rows.Count, j).End(xlUp).Row
        For i = 2 To UBound(ar)
            If ar(i, j) <> "" Then
                xh = d(ar(i, j))
                If xh = "" Then
                    k = k + 1
                    w = j - 1
                    For s = j To j + 2
                        w = w + 1
                        .Cells(k, w) = ar(i, s)
                    Next s
                End If
            End If
        Next i
    Next j
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

模板.rar (42.01 KB, 下载次数: 6)

2024-3-27 11:26 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.27
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("原始").UsedRange
   
5.     ReDim brr(1 To 10000, 1 To UBound(arr, 2))
   
6.     For j = 1 To UBound(arr, 2) Step 3
   
7.         For i = 2 To UBound(arr)
   
8.             If arr(i, j) <> Empty Then
   
9.                 s = arr(i, j)
   
10.                 If Not d.exists(s) Then
    
11.                     m = m + 1
    
12.                     d(s) = m
    
13.                 End If
    
14.             End If
    
15.         Next
    
16.     Next
    
17.     m = 0
    
18.     For j = 1 To UBound(arr, 2) Step 3
    
19.         For i = 2 To UBound(arr)
    
20.             If arr(i, j) <> Empty Then
    
21.                 s = arr(i, j)
    
22.                 If d.exists(s) Then
    
23.                     brr(d(s), j) = arr(i, j)
    
24.                     brr(d(s), j + 1) = arr(i, j + 1)
    
25.                     brr(d(s), j + 2) = arr(i, j + 2)
    
26.                 End If
    
27.             End If
    
28.         Next
    
29.     Next
    
30.     With Sheets("实现效果")
    
31.         .UsedRange.Offset(1) = ""
    
32.         .[a2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
33.     End With
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    
38. 
    

复制代码