根据表一到表四中的内容按要求汇总

风花雪月8888

求大神帮忙根据表一到表四中的内容按要求汇总，感谢感谢

limonet

你要给个量子代码哈，不然，脑电波也找不到数据嘎。

lsc900707

没有附件，很难得到满意的答复！

mryys2000

lsc900707 发表于 2023-2-22 20:35
没有附件，很难得到满意的答复！

版主，加我QQ：1099031084，有关问题请教

h2016

limonet 发表于 2023-2-22 16:21
你要给个量子代码哈，不然，脑电波也找不到数据嘎。

应该和我发的这个大同小异

风花雪月8888

附件没传上来重新传附件

chxw68

1. Sub test()
   
2.     Dim r%, i%, m5
   
3.     Dim arr, brr(1 To 10000, 1 To 3)
   
4.     Dim ws As Worksheet
   
5.     m = 0
   
6.     p = 0
   
7.     For Each ws In Worksheets
   
8.         If ws.Range("a1") = "年" And ws.Range("b1") = "月" Then
   
9.             p = p + 1
   
10.             With ws
    
11.                 r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.                 If r > 1 Then
    
13.                     arr = .Range("a2:e" & r)
    
14.                     For i = 1 To UBound(arr)
    
15.                         m = m + 1
    
16.                         brr(m, 1) = ws.Name & "_" & Format(p, "00")
    
17.                         brr(m, 2) = arr(i, 1) & "年" & arr(i, 2) & "月" & arr(i, 3) & "日" & Space(1) & arr(i, 4)
    
18.                         brr(m, 3) = arr(i, 5)
    
19.                     Next
    
20.                 End If
    
21.             End With
    
22.         End If
    
23.     Next
    
24.     With Worksheets("汇总")
    
25.         .UsedRange.Offset(1, 0).Clear
    
26.         If m > 0 Then
    
27.             .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
28.         End If
    
29.     End With
    
30.                     
    
31. End Sub
    

复制代码

chxw68

详见附件。

huamao720

Sub test()
    Dim sht As Worksheet, i As Integer, j As Integer
    Dim arr()
    Dim brr(1 To 1000, 1 To 3)
   
   
    For Each sht In ThisWorkbook.Worksheets
        If sht.Name <> "汇总" Then
            shname = sht.Name
            arr = sht.UsedRange
            For i = 2 To UBound(arr)
                j = j + 1
                brr(j, 1) = shname
                brr(j, 2) = arr(i, 1) & "年" & arr(i, 2) & "月" & arr(i, 3) & "日  " & arr(i, 4)
                brr(j, 3) = arr(i, 5)
            Next i
        End If
    Next sht
    With Sheet1
        .Range("a2:C1000").Clear
        .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = Application.Transpose(Application.Transpose(brr))
    End With
End Sub

gwjkkkkk

Option Explicit
Sub test()
    Dim ar(), br, i&, r&, wks As Worksheet
   
    With [A1].CurrentRegion
        .Offset(1, 1).ClearContents
        br = .Value
    End With
   
    For Each wks In Sheets
        If wks.Name <> "汇总" Then
           r = r + 1
           ReDim Preserve ar(1 To r)
           With wks.[A1].CurrentRegion
               ar(r) = Intersect(.Offset(), .Offset(1))
           End With
           For i = 1 To UBound(ar(r))
               ar(r)(i, 1) = Format(ar(r)(i, 1) & "-" & ar(r)(i, 2) & "-" & ar(r)(i, 3), "yyyy年m月d日") _
               & ar(r)(i, 4)
               ar(r)(i, 2) = ar(r)(i, 5)
           Next i
           For i = 2 To UBound(br)
               If InStr(br(i, 1), wks.Name) Then
                   Cells(i, 2).Resize(UBound(ar(r)), 2) = ar(r)
                   Exit For
               End If
           Next i
        End If
    Next
   
    Beep
End Sub