[已解决]历遍工作表按要求提取数据的问题

dfshm

附件 历遍工作表按要求提取数据.rar (39.91 KB, 下载次数: 20)

2022-1-12 18:44 上传

点击文件名下载附件
谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

sam-wang

2022-1-12 19:59

請測試看看，謝謝
Sub test()
Dim Arr, T, T1, Brr(1 To 10000, 1 To 13), sh%, i&, n%
T = Sheets(1).[a1]
For sh = 2 To Sheets.Count
    With Sheets(sh)
        Arr = .Range("a1:l" & .[h65536].End(3).Row)
        For i = 1 To UBound(Arr)
            T1 = Arr(i, 8): If T1 = "" Then GoTo 99
            If T = T1 Then
                n = n + 1: For j = 1 To 12: Brr(n, j) = Arr(i, j): Next
                Brr(n, 13) = Sheets(sh).Name
            End If
99:     Next
    End With
Next
If n > 0 Then
    With Sheets(1)
        .Range("a15:m" & .[m65536].End(3).Row).ClearContents
        .[a15].Resize(n, 13) = Brr
    End With
End If
End Sub

跳转到最佳答案楼层

sam-wang

請測試看看，謝謝
Sub test()
Dim Arr, T, T1, Brr(1 To 10000, 1 To 13), sh%, i&, n%
T = Sheets(1).[a1]
For sh = 2 To Sheets.Count
    With Sheets(sh)
        Arr = .Range("a1:l" & .[h65536].End(3).Row)
        For i = 1 To UBound(Arr)
            T1 = Arr(i, 8): If T1 = "" Then GoTo 99
            If T = T1 Then
                n = n + 1: For j = 1 To 12: Brr(n, j) = Arr(i, j): Next
                Brr(n, 13) = Sheets(sh).Name
            End If
99:     Next
    End With
Next
If n > 0 Then
    With Sheets(1)
        .Range("a15:m" & .[m65536].End(3).Row).ClearContents
        .[a15].Resize(n, 13) = Brr
    End With
End If
End Sub