Extraction same sheet name from files in folder and merge the same price

A

abdo meghari

Well-known Member
Joined
Aug 3, 2021
Messages
664
Office Version
  1. 2019
Hello,
I would macro, not POWER QUERY to extract the whole sheets from files are existed in directory D:\ab\INVOICES
so every file contains one sheet , the same sheet name .
INV1.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR4.00500.002,000.00
232VEGA 55A R KOR2.00425.00850.00
243LARGEST 60A L HIGH JAP2.00440.00880.00
254KM 215/65R16 TA31 KOR4.00460.001,840.00
265265/70R16 ALGERIA4.00630.002,520.00
276KM 205/65R16 HS63 KOR4.00445.001,780.00
287GC 385/65R22.5 AT131 CHI2.001,650.003,300.00
298KM 265/70R16 KOR4.00880.003,520.00
309DONGA 66A L KOR2.00460.00920.00
3110KM 235/65R17 HP71 KOR4.00625.002,500.00
3211KM 235/55R19 PS71 KOR4.00675.002,700.00
3312DROUB 90A L KOR1.00575.00575.00
3413KM 13R22.5 MA11 KOR2.002,550.005,100.00
35TOTAL39.0028,485.00
SH1
Cell Formulas
RangeFormula
D35,F35D35=SUM(D22:D34)
F22:F34F22=E22*D22



INV2.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR1.00500.00500.00
232VEGA 55A R KOR2.00425.00850.00
243LARGEST 60A L HIGH JAP2.00440.00880.00
254KM 215/65R16 TA31 KOR1.00460.00460.00
265265/70R16 ALGERIA4.00630.002,520.00
276KM 205/65R16 HS63 KOR4.00450.001,800.00
287GC 385/65R22.5 AT131 CHI12.001,640.0019,680.00
298KM 265/70R16 KOR4.00880.003,520.00
309KM 235/65R17 HP71 KOR1.00875.00875.00
3110KM 235/55R19 PS71 KOR2.00670.001,340.00
32TOTAL33.0032,425.00
SH1
Cell Formulas
RangeFormula
D32,F32D32=SUM(D22:D31)
F22:F31F22=E22*D22



INV3.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221BJS 13R22.5 MA11 KOR10.002,555.0025,550.00
232KM 13R22.5 MA11 KOR12.002,000.0024,000.00
24TOTAL22.0049,550.00
SH1
Cell Formulas
RangeFormula
D24,F24D24=SUM(D22:D23)
F22:F23F22=D22*E22



so the result in OUTPUT file into result sheet will already be existed and rename sheet for each file contains same sheet name based on file name INV1,INV2,INV3 before RESULT sheet. after data copy the data from sheets and merge QTY in column D for each brand IN COLUMN C if the price is the same thing in column E for duplicates brands whether in the same sheet or all of sheets across files otherwise don't merge , surely without forget insert TOTAL row to sum amounts.


before
OUTPUT.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
22
23
24
25
26
27
28
RESULT




after
OUTPUT.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR5500.002,500.00
232VEGA 55A R KOR4425.001,700.00
243LARGEST 60A L HIGH JAP4440.001,760.00
254KM 215/65R16 TA31 KOR5460.002,300.00
265265/70R16 ALGERIA8630.005,040.00
276KM 205/65R16 HS63 KOR4445.001,780.00
287GC 385/65R22.5 AT131 CHI21,650.003,300.00
298KM 265/70R16 KOR8880.007,040.00
309DONGA 66A L KOR2460.00920.00
3110KM 235/65R17 HP71 KOR4625.002,500.00
3211KM 235/55R19 PS71 KOR4675.002,700.00
3312DROUB 90A L KOR1575.00575.00
3413KM 13R22.5 MA11 KOR22,550.005,100.00
3514KM 205/65R16 HS63 KOR4450.001,800.00
3615GC 385/65R22.5 AT131 CHI121,640.0019,680.00
3716KM 235/65R17 HP71 KOR1875.00875.00
3817KM 235/55R19 PS71 KOR2670.001,340.00
3918BJS 13R22.5 MA11 KOR102,555.0025,550.00
4019KM 13R22.5 MA11 KOR122,000.0024,000.00
41TOTAL94110,460.00
RESULT
Cell Formulas
RangeFormula
D41,F41D41=SUM(D22:D40)

every time when run macro should delete sheets before RESULT sheet also delete data in RESULT sheet before brings data.
thanks
 
Sort by date Sort by votes
Thanks again.
I have notes about what I ask in OP
and merge QTY in column D for each brand IN COLUMN C if the price is the same thing in column E for duplicates brands whether in the same sheet or all of sheets across files
Click to expand...
the code will merge duplicates brand across files when duplicate brand for each sheet file, but what about if the duplicate brand is existed in the same sheet for each file too.
obviously the code ignores, should merge whether in the same sheet for each file or each sheet for each file.
the code deals more than three files as in OP?
because it just work for three files , why?
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
abdo meghari said:
the code deals more than three files as in OP?
because it just work for three files , why?
Click to expand...
The code assumes that all your source files begin with "INV" so it will deal only with those files. If only three of the files begin with "INV" then it will work only for three files.
abdo meghari said:
should merge whether in the same sheet for each file or each sheet for each file.
Click to expand...
This version should take care of this issue:
VBA Code: 
Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim lRow As Long, dic As Object, v As Variant, i As Long, ws As Worksheet
    Dim desWB As Workbook, desWS As Worksheet, srcWB As Workbook, val As String, fnd As Range
    Set desWB = ThisWorkbook
    Set desWS = desWB.Sheets("RESULT")
    With desWS.UsedRange
        .Offset(1).ClearContents
        .Borders.LineStyle = xlNone
    End With
    With desWB
        Application.DisplayAlerts = False
        For Each ws In .Sheets
            If ws.Name <> desWS.Name Then
                ws.Delete
            End If
        Next ws
        Application.DisplayAlerts = True
    End With
    Const strPath As String = "D:\ab\INVOICES\"
    strExtension = Dir(strPath & "INV*.xlsm")
    Set dic = CreateObject("Scripting.Dictionary")
    Do While strExtension <> ""
        If strExtension Like "INV*" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            Sheets("SH1").Copy before:=desWB.Sheets("RESULT")
            ActiveSheet.Name = Split(srcWB.Name, ".")(0)
            srcWB.Close savechanges:=False
            With ActiveSheet
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                v = .Range("C22:C" & lRow - 1).Resize(, 3).Value
                For i = LBound(v) To UBound(v)
                    val = v(i, 1) & "|" & v(i, 3)
                    If Not dic.exists(val) Then
                        dic.Add val, v(i, 2)
                        With desWS
                            .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(, 3).Value = Array(v(i, 1), v(i, 2), v(i, 3))
                        End With
                    Else
                        With desWS
                            Set fnd = .Range("C:C").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole)
                            .Range("C" & fnd.Row).Resize(, 3).Value = Array(v(i, 1), v(i, 2) + .Range("D" & fnd.Row), v(i, 3))
                        End With
                    End If
                Next i
            End With
        End If
        strExtension = Dir
    Loop
    desWS.Activate
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("B22").Value = "1"
    Range("B22").AutoFill Destination:=Range("B22").Resize(lRow - 21), Type:=xlFillSeries
    Range("B" & lRow + 1) = "TOTAL"
    Range("F22:F" & lRow).Formula = "=D22*E22"
    Range("D" & lRow + 1).Formula = "=sum(D22:D" & lRow & ")"
    Range("F" & lRow + 1).Formula = "=sum(F22:F" & lRow & ")"
    Range("E22:F" & lRow + 1).NumberFormat = "#,##0.00"
    ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
The code assumes that all your source files begin with "INV" so it will deal only with those files. If only three of the files begin with "INV" then it will work only for three files.
Click to expand...
I know , is it from version ?
because I used 2010 in that moment.
with office 2016 works . but merging doesn't work correctly
I will take KM 13R22.5 MA11 KOR as in example
SUMMARY.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR45002000
232VEGA 55A R KOR2425850
243LARGEST 60A L HIGH JAP2440880
254KM 215/65R16 TA31 KOR44601840
265265/70R16 ALGERIA46302520
276KM 205/65R16 HS63 KOR44451780
287GC 385/65R22.5 AT131 CHI216503300
298KM 265/70R16 KOR48803520
309DONGA 66A L KOR2460920
3110KM 235/65R17 HP71 KOR46252500
3211KM 235/55R19 PS71 KOR46752700
3312DROUB 90A L KOR1575575
3413KM 13R22.5 MA11 KOR225505100
35TOTAL3928485
INV1
Cell Formulas
RangeFormula
D35,F35D35=SUM(D22:D34)
F22:F34F22=E22*D22


SUMMARY.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221BJS 13R22.5 MA11 KOR10255525550
232KM 13R22.5 MA11 KOR12200024000
243KM 13R22.5 MA11 KOR12200024000
25TOTAL2249550
INV3
Cell Formulas
RangeFormula
D25,F25D25=SUM(D22:D23)
F22:F24F22=D22*E22


SUMMARY.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221BJS 14R22.5 MA11 KOR10250025000
232KM 14R22.5 MA11 KOR12250030000
243KM 13R22.5 MA11 KOR12200024000
25TOTAL2255000
INV4
Cell Formulas
RangeFormula
D25,F25D25=SUM(D22:D23)
F22:F24F22=D22*E22


SUMMARY.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR6500.003,000.00
232VEGA 55A R KOR4425.001,700.00
243LARGEST 60A L HIGH JAP4440.001,760.00
254KM 215/65R16 TA31 KOR5460.002,300.00
265265/70R16 ALGERIA8630.005,040.00
276KM 205/65R16 HS63 KOR4445.001,780.00
287GC 385/65R22.5 AT131 CHI21,650.003,300.00
298KM 265/70R16 KOR8880.007,040.00
309DONGA 66A L KOR2460.00920.00
3110KM 235/65R17 HP71 KOR4625.002,500.00
3211KM 235/55R19 PS71 KOR4675.002,700.00
3312DROUB 90A L KOR1575.00575.00
3413KM 13R22.5 MA11 KOR262,000.0052,000.00
3514KM 205/65R16 HS63 KOR4450.001,800.00
3615GC 385/65R22.5 AT131 CHI121,640.0019,680.00
3716KM 235/65R17 HP71 KOR1875.00875.00
3817KM 235/55R19 PS71 KOR2670.001,340.00
3918VEGA 70A R KOR2510.001,020.00
4019BJS 13R22.5 MA11 KOR102,555.0025,550.00
4120KM 13R22.5 MA11 KOR122,000.0024,000.00
4221BJS 14R22.5 MA11 KOR102,500.0025,000.00
4322KM 14R22.5 MA11 KOR122,500.0030,000.00
44TOTAL143213,880.00
RESULT
Cell Formulas
RangeFormula
D44,F44D44=SUM(D22:D43)
F22:F43F22=D22*E22


should merge items 13,20 and there is missed item 13 in INV1 sheet and doesn't show in result sheet.
 
Upvote 0
Try:
VBA Code: 
Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim lRow As Long, dic As Object, v As Variant, i As Long, ws As Worksheet
    Dim desWB As Workbook, desWS As Worksheet, srcWB As Workbook, val As String, fnd As Range
    Set desWB = ThisWorkbook
    Set desWS = desWB.Sheets("RESULT")
    With desWS.UsedRange
        .Offset(1).ClearContents
        .Borders.LineStyle = xlNone
    End With
    With desWB
        Application.DisplayAlerts = False
        For Each ws In .Sheets
            If ws.Name <> desWS.Name Then
                ws.Delete
            End If
        Next ws
        Application.DisplayAlerts = True
    End With
    'Const strPath As String = "D:\ab\INVOICES\"
    Const strPath As String = "C:\Mario\Forum Help\"
    strExtension = Dir(strPath & "INV*.xlsm")
    Set dic = CreateObject("Scripting.Dictionary")
    Do While strExtension <> ""
        If strExtension Like "INV*" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            Sheets("SH1").Copy before:=desWB.Sheets("RESULT")
            ActiveSheet.Name = Split(srcWB.Name, ".")(0)
            srcWB.Close savechanges:=False
            With ActiveSheet
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                v = .Range("C22:C" & lRow - 1).Resize(, 3).Value
                For i = LBound(v) To UBound(v)
                    val = v(i, 1) & "|" & v(i, 3)
                    If Not dic.exists(val) Then
                        dic.Add val, v(i, 2)
                        With desWS
                            .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(, 3).Value = Array(v(i, 1), v(i, 2), v(i, 3))
                        End With
                    Else
                        With desWS
                            Set fnd = .Range("C:C").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole)
                            If .Range("E" & fnd.Row) <> v(i, 3) Then
                                Set fnd = .Range("C:C").FindNext(fnd)
                                .Range("C" & fnd.Row).Resize(, 3).Value = Array(v(i, 1), v(i, 2) + .Range("D" & fnd.Row), v(i, 3))
                            End If
                        End With
                    End If
                Next i
            End With
        End If
        strExtension = Dir
    Loop
    desWS.Activate
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("B22").Value = "1"
    Range("B22").AutoFill Destination:=Range("B22").Resize(lRow - 21), Type:=xlFillSeries
    Range("B" & lRow + 1) = "TOTAL"
    Range("F22:F" & lRow).Formula = "=D22*E22"
    Range("D" & lRow + 1).Formula = "=sum(D22:D" & lRow & ")"
    Range("F" & lRow + 1).Formula = "=sum(F22:F" & lRow & ")"
    Range("E22:F" & lRow + 1).NumberFormat = "#,##0.00"
    ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
still doesn't merge some items
example : VEGA 70A R KOR
SUMMARY.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR45002000
232VEGA 55A R KOR2425850
243LARGEST 60A L HIGH JAP2440880
254KM 215/65R16 TA31 KOR44601840
265265/70R16 ALGERIA46302520
276KM 205/65R16 HS63 KOR44451780
287GC 385/65R22.5 AT131 CHI216503300
298KM 265/70R16 KOR48803520
309DONGA 66A L KOR2460920
3110KM 235/65R17 HP71 KOR46252500
3211KM 235/55R19 PS71 KOR46752700
3312DROUB 90A L KOR1575575
3413KM 13R22.5 MA11 KOR225505100
35TOTAL3928485
INV1
Cell Formulas
RangeFormula
D35,F35D35=SUM(D22:D34)
F22:F34F22=E22*D22



SUMMARY.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR1500500
232VEGA 55A R KOR2425850
243LARGEST 60A L HIGH JAP2440880
254KM 215/65R16 TA31 KOR1460460
265265/70R16 ALGERIA46302520
276KM 205/65R16 HS63 KOR44501800
287GC 385/65R22.5 AT131 CHI12164019680
298KM 265/70R16 KOR48803520
309KM 235/65R17 HP71 KOR1875875
3110KM 235/55R19 PS71 KOR26701340
3211VEGA 70A R KOR1500500
3312VEGA 70A R KOR25101020
34TOTAL3633945
INV2
Cell Formulas
RangeFormula
D34,F34D34=SUM(D22:D33)
F22:F33F22=E22*D22




SUMMARY.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR4500.002,000.00
232VEGA 55A R KOR2425.00850.00
243LARGEST 60A L HIGH JAP2440.00880.00
254KM 215/65R16 TA31 KOR4460.001,840.00
265265/70R16 ALGERIA4630.002,520.00
276KM 205/65R16 HS63 KOR4445.001,780.00
287GC 385/65R22.5 AT131 CHI21,650.003,300.00
298KM 265/70R16 KOR4880.003,520.00
309DONGA 66A L KOR2460.00920.00
3110KM 235/65R17 HP71 KOR4625.002,500.00
3211KM 235/55R19 PS71 KOR4675.002,700.00
3312DROUB 90A L KOR1575.00575.00
3413KM 13R22.5 MA11 KOR22,550.005,100.00
3514KM 205/65R16 HS63 KOR4450.001,800.00
3615GC 385/65R22.5 AT131 CHI121,640.0019,680.00
3716KM 235/65R17 HP71 KOR1875.00875.00
3817KM 235/55R19 PS71 KOR2670.001,340.00
3918VEGA 70A R KOR2510.001,020.00
4019BJS 13R22.5 MA11 KOR102,555.0025,550.00
4120KM 13R22.5 MA11 KOR362,000.0072,000.00
4221BJS 14R22.5 MA11 KOR102,500.0025,000.00
4322KM 14R22.5 MA11 KOR122,500.0030,000.00
44TOTAL128205,750.00
RESULT
Cell Formulas
RangeFormula
D44,F44D44=SUM(D22:D43)
F22:F43F22=D22*E22
 
Upvote 0
Try:
VBA Code: 
Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim lRow As Long, dic As Object, v As Variant, i As Long, ws As Worksheet, sAddr As String
    Dim desWB As Workbook, desWS As Worksheet, srcWB As Workbook, val As String, fnd As Range
    Set desWB = ThisWorkbook
    Set desWS = desWB.Sheets("RESULT")
    With desWS.UsedRange
        .Offset(1).ClearContents
        .Borders.LineStyle = xlNone
    End With
    With desWB
        Application.DisplayAlerts = False
        For Each ws In .Sheets
            If ws.Name <> desWS.Name Then
                ws.Delete
            End If
        Next ws
        Application.DisplayAlerts = True
    End With
    Const strPath As String = "D:\ab\INVOICES\"
    strExtension = Dir(strPath & "INV*.xlsm")
    Set dic = CreateObject("Scripting.Dictionary")
    Do While strExtension <> ""
        If strExtension Like "INV*" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            Sheets("SH1").Copy before:=desWB.Sheets("RESULT")
            ActiveSheet.Name = Split(srcWB.Name, ".")(0)
            srcWB.Close savechanges:=False
            With ActiveSheet
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                v = .Range("C22:C" & lRow - 1).Resize(, 3).Value
                For i = LBound(v) To UBound(v)
                    val = v(i, 1) & "|" & v(i, 3)
                    If Not dic.exists(val) Then
                        dic.Add val, v(i, 2)
                        With desWS
                            .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(, 3).Value = Array(v(i, 1), v(i, 2), v(i, 3))
                        End With
                    Else
                        With desWS
                            Set fnd = .Range("C:C").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole)
                            sAddr = fnd.Address
                            If .Range("E" & fnd.Row) = v(i, 3) Then
                                Do
                                    .Range("C" & fnd.Row).Resize(, 3).Value = Array(v(i, 1), v(i, 2) + .Range("D" & fnd.Row), v(i, 3))
                                    Set fnd = ActiveSheet.Range("C:C").FindNext(fnd)
                                Loop While fnd.Address <> sAddr
                                sAddr = ""
                            End If
                        End With
                    End If
                Next i
            End With
        End If
        strExtension = Dir
    Loop
    desWS.Activate
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("B22").Value = "1"
    Range("B22").AutoFill Destination:=Range("B22").Resize(lRow - 21), Type:=xlFillSeries
    Range("B" & lRow + 1) = "TOTAL"
    Range("F22:F" & lRow).Formula = "=D22*E22"
    Range("D" & lRow + 1).Formula = "=sum(D22:D" & lRow & ")"
    Range("F" & lRow + 1).Formula = "=sum(F22:F" & lRow & ")"
    Range("E22:F" & lRow + 1).NumberFormat = "#,##0.00"
    ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
still problem !
OUTPUT.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR4500.002,000.00
232VEGA 55A R KOR2425.00850.00
243LARGEST 60A L HIGH JAP2440.00880.00
254KM 215/65R16 TA31 KOR4460.001,840.00
265265/70R16 ALGERIA4630.002,520.00
276KM 205/65R16 HS63 KOR4445.001,780.00
287GC 385/65R22.5 AT131 CHI21,650.003,300.00
298KM 265/70R16 KOR4880.003,520.00
309DONGA 66A L KOR2460.00920.00
3110KM 235/65R17 HP71 KOR4625.002,500.00
3211KM 235/55R19 PS71 KOR4675.002,700.00
3312DROUB 90A L KOR1575.00575.00
3413KM 13R22.5 MA11 KOR22,550.005,100.00
3514VEGA 70A R KOR1500.00500.00
3615KM 215/65R16 TA31 KOR2460.00920.00
3716KM 215/65R16 TA31 KOR2450.00900.00
38TOTAL4430,805.00
INV1
Cell Formulas
RangeFormula
D38,F38D38=SUM(D22:D37)
F22:F37F22=E22*D22



OUTPUT.xlsm
BCDEF
21ITEMBRANDQTYPRICEBALANCE
221VEGA 70A R KOR1500.00500.00
232VEGA 55A R KOR2425.00850.00
243LARGEST 60A L HIGH JAP2440.00880.00
254KM 215/65R16 TA31 KOR1460.00460.00
265265/70R16 ALGERIA4630.002,520.00
276KM 205/65R16 HS63 KOR4450.001,800.00
287GC 385/65R22.5 AT131 CHI121,640.0019,680.00
298KM 265/70R16 KOR4880.003,520.00
309KM 235/65R17 HP71 KOR1875.00875.00
3110KM 235/55R19 PS71 KOR2670.001,340.00
32TOTAL3332,425.00
INV2
Cell Formulas
RangeFormula
D32,F32D32=SUM(D22:D31)
F22:F31F22=E22*D22



after merging will repeat showing as in items 15,16 !
 
Upvote 0
Try:
VBA Code: 
Sub CopySheetData()
    Application.ScreenUpdating = False
    Dim lRow As Long, dic As Object, v As Variant, i As Long, ws As Worksheet, sAddr As String
    Dim desWB As Workbook, desWS As Worksheet, srcWB As Workbook, val As String, fnd As Range, fnd2 As Range
    Set desWB = ThisWorkbook
    Set desWS = desWB.Sheets("RESULT")
    With desWS.UsedRange
        .Offset(1).ClearContents
        .Borders.LineStyle = xlNone
    End With
    With desWB
        Application.DisplayAlerts = False
        For Each ws In .Sheets
            If ws.Name <> desWS.Name Then
                ws.Delete
            End If
        Next ws
        Application.DisplayAlerts = True
    End With
    Const strPath As String = "D:\ab\INVOICES\"
    strExtension = Dir(strPath & "INV*.xlsm")
    Set dic = CreateObject("Scripting.Dictionary")
    Do While strExtension <> ""
        If strExtension Like "INV*" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            Sheets("SH1").Copy before:=desWB.Sheets("RESULT")
            ActiveSheet.Name = Split(srcWB.Name, ".")(0)
            srcWB.Close savechanges:=False
            With ActiveSheet
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                v = .Range("C22:C" & lRow - 1).Resize(, 3).Value
                For i = LBound(v) To UBound(v)
                    val = v(i, 1) & "|" & v(i, 3)
                    If Not dic.exists(val) Then
                        dic.Add val, v(i, 2)
                        With desWS
                            .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(, 3).Value = Array(v(i, 1), v(i, 2), v(i, 3))
                        End With
                    Else
                        With desWS
                            Set fnd = .Range("C:C").Find(v(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
                            If .Range("E" & fnd.Row) = v(i, 3) Then
                                .Range("C" & fnd.Row).Resize(, 3).Value = Array(v(i, 1), v(i, 2) + .Range("D" & fnd.Row), v(i, 3))
                            Else
                                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                Set fnd = .Range("C" & fnd.Row + 1 & ":C" & lRow).Find(v(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
                                Set fnd2 = ActiveSheet.Range("C" & i + 21 & ":C" & lRow).Find(v(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
                                If Not fnd2 Is Nothing Then
                                    sAddr = fnd2.Address
                                    Do
                                        If .Range("E" & fnd.Row) = v(i, 3) Then
                                            .Range("C" & fnd.Row).Resize(, 3).Value = Array(v(i, 1), v(i, 2) + .Range("D" & fnd.Row), v(i, 3))
                                            Set fnd2 = ActiveSheet.Range("C" & fnd.Row + 1 & ":C" & lRow).Find(fnd2, LookIn:=xlValues, LookAt:=xlWhole)
                                        End If
                                    Loop While Not fnd2 Is Nothing
                                    sAddr = ""
                                End If
                            End If
                        End With
                    End If
                Next i
            End With
        End If
        strExtension = Dir
    Loop
    desWS.Activate
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("B22").Value = "1"
    Range("B22").AutoFill Destination:=Range("B22").Resize(lRow - 21), Type:=xlFillSeries
    Range("B" & lRow + 1) = "TOTAL"
    Range("F22:F" & lRow).Formula = "=D22*E22"
    Range("D" & lRow + 1).Formula = "=sum(D22:D" & lRow & ")"
    Range("F" & lRow + 1).Formula = "=sum(F22:F" & lRow & ")"
    Range("E22:F" & lRow + 1).NumberFormat = "#,##0.00"
    Range("B21:F" & lRow + 1).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
seem to be work, but I need more time to check all of items to make sure there is no problem .
also if you have idea why doesn't import all of data from all of files with version 2010 ( I have four files contains INV*, just import from three files!) as I mentioned in post # 13
 
Upvote 0
Please post the full names of the four files including the extension.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
rename sheet based on number format in last row for each sheet
2
Replies
17
Views
249
Peter_SSs
Peter_SSs
A
  • Solved
Populate data under header and combined based on the same price
Replies
4
Views
121
abdo meghari
A
A
  • Solved
Compare two sheets based on lastrow with highlighted cells
2 3
Replies
26
Views
417
mumps
mumps
A
  • Solved
Tracing sum cells up to match with cell in last row for another sheet
Replies
2
Views
90
abdo meghari
A
A
  • Solved
Autonumbering in cell based on last row in column
Replies
2
Views
108
abdo meghari
A

Forum statistics

Threads
1,225,504
Messages
6,185,361
Members
453,288
Latest member
rlmorales2000

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top