批量跨表复制并置换升序排列

LVMJ2023

各位老师好，请指教

3190496160

Sub 汇总()
Dim ar As Variant
Dim br()
ReDim br(1 To 100000, 1 To 2)
For Each sh In Sheets
    If IsNumeric(sh.Name) Then
        ar = sh.UsedRange
        For j = 11 To UBound(ar, 2) Step 4
            For i = 2 To UBound(ar)
                If Trim(ar(i, j)) <> "" Then
                    If IsNumeric(ar(i, j)) Then
                        n = n + 1
                        br(n, 1) = ar(i - 1, j)
                        br(n, 2) = ar(i, j)
                    End If
                End If
            Next i
        Next j
    End If
Next sh
If n = "" Then MsgBox "没有需要汇总的数据！": End
rr = Array("均", "标", "和")
With Sheets("汇总")
    .UsedRange.Offset(2) = Empty
    h = 1
    For s = 0 To UBound(rr)
        m = 0
        ReDim cr(1 To n, 1 To 2)
        For i = 1 To n
            If InStr(br(i, 1), rr(s)) > 0 Then
                m = m + 1
                cr(m, 1) = br(i, 1)
                cr(m, 2) = br(i, 2)
            End If
        Next i
        If m > 0 Then .Cells(3, h).Resize(m, 2) = cr
        h = h + 4
    Next s
End With
MsgBox "ok!"
End Sub

3190496160

3190496160

批量跨表复制升序.rar (843.96 KB, 下载次数: 5)

2023-2-2 12:53 上传

点击文件名下载附件

3190496160

排序的代码没有写，实在需要再说吧，

LVMJ2023

3190496160 发表于 2023-2-2 12:54
排序的代码没有写，实在需要再说吧，

谢谢老师，我先试下，排序我自己手动排也行的

LVMJ2023

3190496160 发表于 2023-2-2 12:53

暂时没有花，等有花了再过来评分

ykcbf1100

参与一下。

LVMJ2023

ykcbf1100 发表于 2023-2-2 13:57
参与一下。

收到感谢

3190496160

排序
Sub 汇总()
Dim ar As Variant
Dim br()
ReDim br(1 To 100000, 1 To 2)
For Each sh In Sheets
    If IsNumeric(sh.Name) Then
        ar = sh.UsedRange
        For j = 11 To UBound(ar, 2) Step 4
            For i = 2 To UBound(ar)
                If Trim(ar(i, j)) <> "" Then
                    If IsNumeric(ar(i, j)) Then
                        n = n + 1
                        br(n, 1) = ar(i - 1, j)
                        br(n, 2) = ar(i, j)
                    End If
                End If
            Next i
        Next j
    End If
Next sh
If n = "" Then MsgBox "没有需要汇总的数据！": End
rr = Array("均", "标", "和")
With Sheets("汇总")
    .UsedRange.Offset(2) = Empty
    h = 1
    For s = 0 To UBound(rr)
        m = 0
        ReDim cr(1 To n, 1 To 2)
        For i = 1 To n
            If InStr(br(i, 1), rr(s)) > 0 Then
                m = m + 1
                cr(m, 1) = br(i, 1)
                cr(m, 2) = br(i, 2)
            End If
        Next i
        If m > 0 Then
            For i = 1 To m
                For ss = i + 1 To m
                    If cr(i, 2) > cr(ss, 2) Then
                        For j = 1 To 2
                            k = cr(i, j)
                            cr(i, j) = cr(ss, j)
                            cr(ss, j) = k
                        Next j
                    End If
                Next ss
            Next i
            .Cells(3, h).Resize(m, 2) = cr
        End If
        h = h + 4
    Next s
End With
MsgBox "ok!"
End Sub