提取区域

ddz79101

老师！我希望提取各表的姓名及其对应的小计区域到合并表。请老师帮忙看看。谢谢

limonet

先解释下AAA为什么不统计？

liulang0808

Sub 矩形1_Click()
    Dim sm As Double
    Set sh = Sheets("合并")
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    sh.UsedRange.Offset(2).ClearContents
    arr = sh.[a1].Resize(9999, 10)
    r = 2
    crr = Array("供", "产", "销", 8, 6, 4)
    For j = 0 To 2
        Set Rng = Sheets(crr(j)).Rows(1).Find("小计", lookat:=xlWhole)
        If Not Rng Is Nothing Then
            c = Rng.Column
            brr = Sheets(crr(j)).UsedRange
            For i = 3 To UBound(brr)
                If brr(i, 1) = "合计" Then Exit For
                If Not d.exists(brr(i, 1)) Then
                    r = r + 1
                    d(brr(i, 1)) = r
                    arr(r, 1) = brr(i, 1)
                    For x = c To c + 2
                        arr(r, j * 3 + 2 + x - c) = brr(i, x)
                    Next x
                Else
                    rx = d(brr(i, 1))
                    For x = c To c + 2
                        arr(rx, j * 3 + 2 + x - c) = brr(i, x)
                    Next x
                End If
            Next i
        End If
    Next j
    arr(r + 1, 1) = "合计"
    For j = 2 To UBound(arr, 2)
        sm = 0
        For i = 3 To r
            sm = sm + arr(i, j)
        Next i
        arr(r + 1, j) = sm
    Next j
    sh.[a1].Resize(r + 1, 10) = arr
    sh.[a3].Resize(r - 2).Sort Key1:=sh.[a17], Order1:=xlAscending
    Application.ScreenUpdating = True
End Sub

liulang0808

提取结果供参考。。。。。

ddz79101

limonet 发表于 2025-5-9 11:01
先解释下AAA为什么不统计？

谢谢老师！漏了。上传的附件是部分。

ddz79101

liulang0808 发表于 2025-5-9 11:19
提取结果供参考。。。。。

谢谢老师！运行成功

清风竹-

请参考。。

limonet

Sub limonet()
    Dim Cn As Object, StrSQL1$, StrSQL$, Sht As Worksheet, ArrTmp As Variant, Field$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name <> "合并" Then
            StrSQL = StrSQL & " Union Select * From [" & Sht.Name & "$A3:A] Where F1<>'合计' And F1<>'差额'"
        End If
    Next Sht
    StrSQL = Mid(StrSQL, 8)
    For Each Sht In Worksheets
        If Sht.Name <> "合并" Then
            ArrTmp = Intersect(Sht.Range("A1").CurrentRegion, Sht.Rows("1:1"))
            i = UBound(ArrTmp, 2)
            Field = ""
            Do
                 Field = "b.F" & i & "," & Field
                 i = i - 1
            Loop Until ArrTmp(1, i) = "小计"
            Field = "b.F" & i & "," & Left(Field, Len(Field) - 1)
            Debug.Print Field
            L$ = Left(Cells(1, i + 2).Address(, 0), 1)
            StrSQL = "Select a.*," & Field & " From (" & StrSQL & ")a Left Join (Select * From [" & Sht.Name & "$A3:" & L & "] Where F1<>'合计' And F1<>'差额')b On a.F1=b.F1"
        End If
    Next Sht
    Range("A3").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

limonet

left join+do until

ddz79101

limonet 发表于 2025-5-9 12:12
left join+do until

谢谢老师！运行成功