排序并提取行数据的问题

杨小妹

附件 排序并提取行数据.rar (49.48 KB, 下载次数: 11)

2024-12-17 17:10 上传

点击文件名下载附件

谢谢老师！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr(1 To 10000, 1 To 5)
   
4.     Dim mypath$, myname$
   
5.     Dim wb As Workbook
   
6.     Dim ws As Worksheet
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     mypath = ThisWorkbook.Path & ""
   
10.     myname = Dir(mypath & "A*.xlsx")
    
11.     m = 0
    
12.     Do While myname <> ""
    
13.         Set wb = GetObject(mypath & myname)
    
14.         wbname = Split(myname, ".")(0)
    
15.         Windows(wb.Name).Visible = True
    
16.         With wb
    
17.             With .Worksheets("sheet2")
    
18.                 r = .Cells(.Rows.Count, 6).End(xlUp).Row
    
19.                 If r > 1 Then
    
20.                     .Range("f1:i" & r).Sort key1:=.Range("g1"), order1:=xlAscending, Header:=xlNo
    
21.                     arr = .Range("f1:i" & r + 1)
    
22.                     i0 = 1
    
23.                     For i = 2 To UBound(arr)
    
24.                         If arr(i, 4) <> arr(i0, 4) Then
    
25.                             If i - i0 > 1 Then
    
26.                                 For x = i0 To i - 1
    
27.                                     m = m + 1
    
28.                                     For j = 1 To UBound(arr, 2)
    
29.                                         brr(m, j) = arr(x, j)
    
30.                                     Next
    
31.                                     brr(m, 5) = wbname
    
32.                                 Next
    
33.                             End If
    
34.                             i0 = i
    
35.                         End If
    
36.                     Next
    
37.                 End If
    
38.             End With
    
39.             .Close False
    
40.         End With
    
41.         myname = Dir
    
42.     Loop
    
43.     With Worksheets("sheet1")
    
44.         If m > 0 Then
    
45.             .Range("g1").Resize(m, UBound(brr, 2)) = brr
    
46.         End If
    
47.     End With
    
48. End Sub
    

复制代码

chxw68

楼主模拟的结果有点误差。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, vResult, i&, j&, k&, r&, n&, p&, strFileName$, strPath$, strName$
   
    Application.ScreenUpdating = False
   
    ReDim vResult(1 To 10 ^ 5, 1 To 5)
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                strName = Left(strFileName, InStrRev(strFileName, ".") - 1)
                With .Worksheets(2)
                    n = .Cells(.Rows.Count, "F").End(xlUp).Row
                    With .Range("F1:I" & n)
                        .Parent.Sort.SortFields.Clear
                        .Sort key1:=.Item(2), Order1:=xlAscending, Header:=xlNo
                        ar = .Resize(.Rows.Count + 1).Value
                        p = 1
                        For i = 1 To UBound(ar) - 1
                            If ar(i + 1, 4) <> ar(p, 4) Then
                                If i - p > 0 Then
                                    br = Range(.Cells(p, 1), .Cells(i, 4)).Value
                                    For k = 1 To UBound(br)
                                        r = r + 1
                                        For j = 1 To UBound(br, 2)
                                            vResult(r, j) = br(k, j)
                                        Next j
                                        vResult(r, 5) = strName
                                    Next k
                                End If
                                p = i + 1
                            End If
                        Next i
                    End With
                End With
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    If r Then
        [A1].CurrentRegion.Clear
        [A1].Resize(r, UBound(vResult, 2)) = vResult
    End If
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。