批量文件获取指定数据生成一个文件对应工作表

lchqfly

如附件，N文件，每个文件只有一个工作表，一个汇总文件按指定格式对应每个文件只提取部分数据然后新建N个工作表，并对工作加边框，添加相应公式，可是我的vba ，处理后 为什么我的汇总文件只有第一个工作表是对的，第二个就不对，第二个工作表多出了第一个的数据，第三个又是多了第一个和第二个的数据，，，，求帮忙看看

网海遨游

每打开一个文件，操作完成，关闭后，将n值用结束后，要初始化n的值，同时清空数组br。在loop之前，加一句n=0:erase br'清空数组

网海遨游

在你代码基础上，略有改动。不知是这样吗？


Sub LCQ()
Dim Mp$, Mf
Dim acount
Application.DisplayAlerts = False
Mp = ThisWorkbook.Path & "\"
Mf = Dir(Mp & "*.xls")
Set D = CreateObject("scripting.dictionary")
For Each sht In Sheets
        If sht.Name <> "模板" Then sht.Delete '此处删除是为了后面改名不因重名而报错
Next sht
Do While Mf <> ""
ReDim br(1 To 1000, 1 To 6)
    If Mf <> ThisWorkbook.Name Then
    S = Split(Mf, "（三供一业）审核确认表")
   If Not D.EXISTS(S(0)) Then
    Sheets("模板").Copy AFTER:=Sheets(Sheets.Count)
   D(S(0)) = 1
    ActiveSheet.Name = S(0)
    ActiveSheet.[A2] = "工程名称：" & S(0)
    End If
   Set WB = Workbooks.Open(Mp & Mf)
    For i = 7 To Cells(65536, 7).End(xlUp).Row
     With ThisWorkbook.Sheets(S(0))
    ar = WB.Worksheets(1).UsedRange
            n = n + 1
            br(n, 1) = n
            br(n, 2) = ar(i, 3)
            br(n, 3) = ar(i, 7)
            br(n, 4) = ar(i, 9)
            br(n, 6) = ar(i, 10)
             If br(n, 6) > 0 Then
             br(n, 5) = ar(i, 8)
              Else
            br(n, 5) = -ar(i, 8)
             End If
            br(n + 1, 2) = "合计"
            br(n + 1, 6) = "=sum(F5:F" & n + 4 & ")"
        End With
        Next
        WB.Close
    End If
    Range("a3:k" & (n + 5)).Borders.LineStyle = 1
    Cells(n + 5, "H") = "=sum(H5:H" & n + 4 & ")"
    Cells(n + 5, "J") = "=sum(J5:J" & n + 4 & ")"
   Range("H5:H" & n + 4).Formula = "=round(D5*G5,2)"
   Range("I5:I" & n + 4).Formula = "=G5-E5"
   Range("j5:j" & n + 4).Formula = "=h5-f5"
Mf = Dir()
Range("a5").Resize(n + 1, 6) = br
n = 0: Erase br
Loop
Application.DisplayAlerts = True
End Sub

liulang0808

做了微调，看看是否满足需求吧

网海遨游

代码在审核中。上图片吧

清风竹-

Sub LCQ()
Dim Mp$, Mf
Dim acount
On Error Resume Next
Mp = ThisWorkbook.Path & "\"
Mf = Dir(Mp & "*.xls")
'ReDim br(1 To 1000, 1 To 6)'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'ReDim cr(1 To 1000, 1 To 3)
'ReDim br(1 To 1000, 1 To 10)
'ReDim mr(1 To 1, 1 To 1)
Set D = CreateObject("scripting.dictionary")
Do While Mf <> ""
    If Mf <> ThisWorkbook.Name Then
    S = Split(Mf, "（三供一业）审核确认表")
   If Not D.EXISTS(S(0)) Then
    Sheets("模板").Copy AFTER:=Sheets(Sheets.Count)
   D(S(0)) = 1
    ActiveSheet.Name = S(0)
    ActiveSheet.[A2] = "工程名称：" & S(0)
    End If
   ReDim br(1 To 1000, 1 To 6) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
   n = 0 '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
   Set WB = Workbooks.Open(Mp & Mf)
    For i = 7 To Cells(65536, 7).End(xlUp).Row
     With ThisWorkbook.Sheets(S(0))
      
    ar = WB.Worksheets(1).UsedRange
   
      'ar = Sheets(1).UsedRange
        
        'For i = 7 To UBound(ar)
      
            n = n + 1
            br(n, 1) = n
            br(n, 2) = ar(i, 3)
            br(n, 3) = ar(i, 7)
            br(n, 4) = ar(i, 9)
            br(n, 6) = ar(i, 10)
            'Cells(n, 6) = ar(i, 10)
            'br(n, 5) = if(br(n, 6)>,ar(i, 6),-ar(i, 6))
             If br(n, 6) > 0 Then
             br(n, 5) = ar(i, 8)
              Else
            br(n, 5) = -ar(i, 8)
             End If
            'br(n, 8) = br(n, 4) * br(n, 7)
            'br(n, 8) = "="
            'cr(n, 1) = br(n, 4) * br(n, 5)
            'mr(1, 1) = "工程名称：" & ar(4, 3)
            'mr(1, 1) = Mid(ar(3, 7), 3, 100)
            br(n + 1, 2) = "合计"
            'acount = acount + br(n, 6)
            'br(n + 1, 6) = acount
            'Cells(n + 5, "F") = "=sum(F5:F" & n + 4 & ")"
            br(n + 1, 6) = "=sum(F5:F" & n + 4 & ")"
         
        'ar.ClearContents
        '.Close 0
        End With
        Next
        WB.Close
    End If

     ActiveSheet.Shapes("Button 1").Select '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
     Selection.Cut
     ActiveSheet.Shapes("Button 2").Select
     Selection.Cut
     ActiveSheet.Shapes("Button 3").Select
     Selection.Cut '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
   
   
   
    Range("a3:k" & (n + 5)).Borders.LineStyle = 1
    'For m = 1 To (n + 4)
    'Cells(m, "h") = "d"&m&"*m"&m&""
    'Next m
    'Cells(n + 6, "h") = "=sum(H5:H" & n & ")"
   
    Cells(n + 5, "H") = "=sum(H5:H" & n + 4 & ")"
    Cells(n + 5, "J") = "=sum(J5:J" & n + 4 & ")"
    'br(n + 1, 5) = "合计"
   'Range(5, 8) = "sum()"
   'r = [a65536].End(3).Row
   
   Range("H5:H" & n + 4).Formula = "=round(D5*G5,2)"
   Range("I5:I" & n + 4).Formula = "=G5-E5"
   Range("j5:j" & n + 4).Formula = "=h5-f5"
Mf = Dir()
Range("a5").Resize(n + 1, 6) = br
Loop
'Range("a5:f1000").ClearContents

'Range("h5").Resize(n + 1, 3) = cr
'Range("a5").Resize(n + 1, 10) = br
'Range("a2").Resize(1, 1) = mr
End Sub

lchqfly

liulang0808 发表于 2019-10-15 20:45
做了微调，看看是否满足需求吧

可以，非常感谢

lchqfly

liulang0808 发表于 2019-10-15 20:45
做了微调，看看是否满足需求吧

可以了，非常感谢，不好意思还想实现一个功能，就是把每个工作表中 把有几行材料名称和单价 都一致的合并成一行

lchqfly

清风竹- 发表于 2019-10-15 21:09
Sub LCQ()
Dim Mp$, Mf
Dim acount

可以了，非常感谢，不好意思还想实现一个功能，就是把每个工作表中 把有几行材料名称和单价 都一致的合并成一行

lchqfly

liulang0808 发表于 2019-10-15 20:45
做了微调，看看是否满足需求吧

可以了，非常感谢，不好意思还想实现一个功能，就是把每个工作表中 把有几行材料名称和单价 都一致的合并成一行