排序并提取行数据的问题

杨小妹 · 发表于 2024-12-17 17:10

本帖最后由杨小妹于 2024-12-17 20:45 编辑

附件

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

谢谢老师！

chxw68 · 发表于 2024-12-17 17:34

Sub test()
Dim r%, i%
Dim arr, brr(1 To 10000, 1 To 5)
Dim mypath$, myname$
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "A*.xlsx")
m = 0
Do While myname <> ""
Set wb = GetObject(mypath & myname)
wbname = Split(myname, ".")(0)
Windows(wb.Name).Visible = True
With wb
With .Worksheets("sheet2")
r = .Cells(.Rows.Count, 6).End(xlUp).Row
If r > 1 Then
.Range("f1:i" & r).Sort key1:=.Range("g1"), order1:=xlAscending, Header:=xlNo
arr = .Range("f1:i" & r + 1)
i0 = 1
For i = 2 To UBound(arr)
If arr(i, 4) <> arr(i0, 4) Then
If i - i0 > 1 Then
For x = i0 To i - 1
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(x, j)
Next
brr(m, 5) = wbname
Next
End If
i0 = i
End If
Next
End If
End With
.Close False
End With
myname = Dir
Loop
With Worksheets("sheet1")
If m > 0 Then
.Range("g1").Resize(m, UBound(brr, 2)) = brr
End If
End With
End Sub

复制代码

chxw68 · 发表于 2024-12-17 17:34

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

gwjkkkkk · 发表于 2024-12-17 21:05

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 · 发表于 2024-12-17 21:06

参与一下。。。

		自动登录	找回密码
密码			免费注册

[已解决] 排序并提取行数据的问题

评分

评分