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

紫寒100

z9bhd 发表于 2021-4-17 21:08
哪个地方有问题？你是点按钮提取的吧？

嗯，我是点按钮提取的。

紫寒100

z9bhd 发表于 2021-4-17 21:27
本来已经改好了，你只要点击下拉箭头就是按条件提取，所以就没有改按钮的对应代码，现在再给你加上就好了 ...

我试了，完美达到需求，谢谢老师。

jjmysjg

留下记号，谢谢老师

xl6403

这个帖子现在已经是多个主题了，与标题大不一样了

紫寒100

z9bhd 发表于 2021-4-17 21:27
本来已经改好了，你只要点击下拉箭头就是按条件提取，所以就没有改按钮的对应代码，现在再给你加上就好了 ...

谢谢老师，是我太笨了，麻烦您了呢。

z9bhd

紫寒100 发表于 2021-4-21 14:14
谢谢老师，是我太笨了，麻烦您了呢。

不麻烦，顺便练习练习，是我没讲清楚

紫寒100

z9bhd 发表于 2021-4-21 14:48
不麻烦，顺便练习练习，是我没讲清楚

老师，不忙的时候，帮我再看看这个多工作簿合并如果合并吗，主要是多表头，有合计行表尾，中间还有空行。具体要求工作簿里也有，数据量大。谢谢了。
求助：多表头有合计行表尾的多工作簿合并
http://club.excelhome.net/thread-1582304-1-1.html
(出处: ExcelHome技术论坛)

z9bhd

紫寒100 发表于 2021-4-21 15:05
老师，不忙的时候，帮我再看看这个多工作簿合并如果合并吗，主要是多表头，有合计行表尾，中间还有空行。 ...

还是那句话，不一定能搞定，不能指望我，不然会影响你的工作，当然我一定会尽力而为的

紫寒100

z9bhd 发表于 2021-4-21 15:16
还是那句话，不一定能搞定，不能指望我，不然会影响你的工作，当然我一定会尽力而为的

谢谢，没关系，我不急的。
主要是麻烦你了

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(), a%
        Set wb1 = ThisWorkbook
        Set sh1 = wb1.Sheets("1-1全部列字段合并")
        Set sh2 = wb1.Sheets("1-2指定列字段合并")
        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)) = UBound(r1, 2) + 1
                           sh1.Cells(1, UBound(r1, 2) + 1) = r2(3, j)
                        End If
                        r3(i - 3, d(r2(3, j))) = r2(i, j)
                    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