【急！】如何从一个Excel表中提取数据，自动填入指定模板，生成多个Excel文件？

z9bhd

紫寒100 发表于 2021-4-21 15:32
谢谢，没关系，我不急的。
主要是麻烦你了

Sub 全部列字段合并()'修改:不用手工填写列标题
    Dim w$, wb As Workbook, wb1 As Workbook, sh As Worksheet, i%, j%
    Dim d As Object, sh1 As Worksheet, sh2 As Worksheet, a%, b%
    Dim r1, r2, r3()
        Set wb1 = ThisWorkbook
        Set sh1 = wb1.Sheets("1-1全部列字段合并")
        sh1.UsedRange.ClearContents
        sh1.[a1].Value = "工作簿名": sh1.[b1].Value = "工作表名"
        Set d = CreateObject("Scripting.Dictionary")
        w = Dir(wb1.Path & "\*.xlsx")
        Do While w <> ""
            a = sh1.Range("d" & Rows.Count).End(xlUp).Row + 1
            b = sh1.Range("a1").End(xlToRight).Column
            r1 = sh1.Range(Cells(1, 1), Cells(1, b))
            For j = 3 To UBound(r1, 2)
                d(r1(1, j)) = j
            Next j
            Set wb = Workbooks.Open(wb1.Path & "\" & w)
            Set sh = wb.Sheets(1)
            r2 = sh.Range("a3").CurrentRegion
            ReDim r3(1 To UBound(r2), 1 To 50)
            For i = 3 To UBound(r2)
                If r2(i, 2) = r2(4, 2) Then
                    For j = 1 To UBound(r2, 2)
                        If d(r2(3, j)) = "" Then
                           d(r2(3, j)) = b + 1
                           sh1.Cells(1, b + 1) = r2(3, j)
                           r3(i - 3, d(r2(3, j))) = r2(i, j)
                           b = sh1.Range("a1").End(xlToRight).Column
                        Else
                            r3(i - 3, d(r2(3, j))) = r2(i, j)
                        End If
                        
                    Next j
                End If
            Next i
            r3(1, 1) = Left(w, Len(w) - 5): r3(1, 2) = sh.Name
            wb.Close 0
            sh1.Range("a" & a).Resize(UBound(r3), UBound(r3, 2)) = r3
           w = Dir
        Loop
End Sub

z9bhd

紫寒100 发表于 2021-4-21 15:32
谢谢，没关系，我不急的。
主要是麻烦你了

试试看，不一定对，有问题再修改 求助：合并多工作簿1.zip (26.7 KB, 下载次数: 59)

2021-4-22 13:05 上传

点击文件名下载附件

紫寒100

z9bhd 发表于 2021-4-22 13:05
试试看，不一定对，有问题再修改

谢谢老师的帮助。很完美。

紫寒100

z9bhd 发表于 2021-4-22 13:05
试试看，不一定对，有问题再修改

按条件提取时，如果想提分配比例，数据提出不出来，是空白的。

紫寒100

z9bhd 发表于 2021-4-22 12:02
Sub 全部列字段合并()'修改:不用手工填写列标题
    Dim w$, wb As Workbook, wb1 As Workbook, sh As W ...

这个代码也非常完美。

z9bhd

紫寒100 发表于 2021-4-22 14:48
这个代码也非常完美。

谢谢鼓励，完美可真不敢说

z9bhd

紫寒100 发表于 2021-4-22 14:30
按条件提取时，如果想提分配比例，数据提出不出来，是空白的。

再修改一下
Sub 指定列字段提取()
    Dim w$, wb As Workbook, wb1 As Workbook, sh As Worksheet, i%, j%
    Dim d As Object, sh1 As Worksheet, sh2 As Worksheet, a%, b%
    Dim r1, r2, r3()
        Set wb1 = ThisWorkbook
        Set sh1 = wb1.Sheets("1-2指定列字段合并")
        Set d = CreateObject("Scripting.Dictionary")
        w = Dir(wb1.Path & "\*.xlsx")
        Do While w <> ""
            a = sh1.Range("c" & Rows.Count).End(xlUp).Row + 1
            b = sh1.Range("a3").End(xlToRight).Column
            r1 = sh1.Range(Cells(3, 1), Cells(3, b))
            For j = 3 To UBound(r1, 2)
                d(r1(1, j)) = j
            Next j
            Set wb = Workbooks.Open(wb1.Path & "\" & w)
            Set sh = wb.Sheets(1)
            r2 = sh.Range("a3").CurrentRegion
            ReDim r3(1 To UBound(r2), 1 To b)
            For i = 4 To UBound(r2)
                If r2(i, 2) = r2(4, 2) Then
                    For j = 1 To UBound(r2, 2)
                        If r2(3, j) = "分配比例" Then r2(i, j) = Format(r2(i, j), "percent")
                       If d(r2(3, j)) <> "" Then
                        r3(i - 3, d(r2(3, j))) = r2(i, j)
                        
                       End If
                    Next j
                End If
            Next i
            r3(1, 1) = Left(w, Len(w) - 5): r3(1, 2) = sh.Name
            wb.Close 0
            sh1.Range("a" & a).Resize(UBound(r3), UBound(r3, 2)) = r3
           w = Dir
        Loop
End Sub

紫寒100

z9bhd 发表于 2021-4-22 13:05
试试看，不一定对，有问题再修改

老师您好，比例可以提取出来了，非常感谢。

紫寒100

z9bhd 发表于 2021-4-22 15:20
谢谢鼓励，完美可真不敢说

真的很完美，谢谢您。

紫寒100

z9bhd 发表于 2021-4-22 13:05
试试看，不一定对，有问题再修改

谢谢，现在运行很标准，流畅，之前也不知道为什么，同一个代码同一个数据源，有时候比例列提取出来了，有时候不能提取出来。