modified code arrange data for multiple sheets into multiple files

[Hasson]

hi
I would modify this code from this thread can sort data based on replace ?

Sub MatchData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, arr1 As Variant, arr2 As Variant, lRow As Long
    Dim dic As Object, srcRng As Range, x As Long, ws As Worksheet
    Set srcWS = Sheets("Sheet1")
    With srcWS
        arr1 = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2).Value
        Set srcRng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With
    For Each ws In Sheets
        If ws.Name <> "Sheet1" Then
            With ws
                arr2 = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2).Value
                Set dic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(arr1, 1)
                    If Not dic.Exists(arr1(i, 1)) Then
                        dic.Add arr1(i, 1), Nothing
                    End If
                Next i
                For i = 1 To UBound(arr2, 1)
                    If dic.Exists(arr2(i, 1)) Then
                        If Not IsError(Application.Match(arr2(i, 1), srcRng, 0)) Then
                            x = Application.Match(arr2(i, 1), srcRng, 0)
                            ws.Range("B" & i + 1).Value = srcWS.Range("B" & x + 1).Value
                        End If
                    End If
                Next i
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Range("D2").FormulaR1C1 = "=MID(RC[-3],FIND(""-"",RC[-3])+1,99999)"
                .Range("D2").AutoFill Destination:=.Range("D2:D" & lRow), Type:=xlFillDefault
                .Range("D2:D" & lRow).Value = .Range("D2:D" & lRow).Value
                .Cells(1, 4).Sort Key1:=.Columns(4), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
                .Columns(4).Delete
                dic.RemoveAll
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

so I have many files contains many sheets . the data in files are not arranged for each sheet . so I want arrange the data for each sheet for each file based on another file
the result should be into files pur1,pur2 based on file search . when arrange data should match the column A across multiple sheets for the files with file SEARCH and arrange again based on file SEARCH
file PUR1

PUR1 .xlsx
	A	B	C
1	ITEM	ID	QTY
2	BS-TA-113	QQW-14 L/R CLA14 SS230 EG DF/100	12.000
3	BS-TA-117	QQW-181 RRSDF BRI	234.000
4	BS-TA-118	QQW-19 CLA19 ITY CV	400.000
5	BS-TA-119	QQW-20 KV/1**2 CLA20 CV	123.000
6	BS-TA-107	QQW-8 CLA8 UKI	456.000
7	BS-TA-108	QQW-9 CLA91 N BR	600.000
REPORT

file PUR2

PUR2.xlsx
	A	B	C
1	ITEM	ID	QTY
2	BS-TA-106	QQW-7 S** CLA7 US BN	200.000
3	BS-TA-107	QQW-8 CLA8 UK ASD	120.000
4	BS-TA-103	QQW-41 M*12.5 CLA4 TR GF	100.000
5	BS-TA-104	QQW-5 CLA5 EG CV NBH-1	120.000
6	BS-TA-105	QQW-612 M230 TU	501.000
DATA

file search

SEARCH.xlsm
	A	B
1	ITEM	ID
2	BS-TA-100	QQW-1 MM CLA1 23M-1 IT
3	BS-TA-101	QQW-2 TH NM-1 CLA2 VBG L CHI
4	BS-TA-102	QQW-3 CV CLA3 TA
5	BS-TA-103	QQW-4 M*12.5 CLA4 TR
6	BS-TA-104	QQW-5 CLA5 EG
7	BS-TA-105	QQW-6 M230 TU
8	BS-TA-106	QQW-7 S** CLA7 US
9	BS-TA-107	QQW-8 CLA8 UK
10	BS-TA-108	QQW-9 CLA9 N BR
11	BS-TA-109	QQW-10 BN CLA10 IT
12	BS-TA-110	QQW-11 LVD CH
13	BS-TA-111	QQW-12 CLA12 JA
14	BS-TA-112	QQW-13 CLA13 TR
15	BS-TA-113	QQW-14 L/R CLA14 SS230 EG
16	BS-TA-114	QQW-15 CLA15 TU
17	BS-TA-115	QQW-16 CLA16 US
18	BS-TA-116	QQW-17 CLA17 UK
19	BS-TA-117	QQW-18 RRSDF BR
20	BS-TA-118	QQW-19 CLA19 IT
21	BS-TA-119	QQW-20 KV/1**2 CLA20 CHI
22
RP

result


file pure1

PUR1 .xlsx
	A	B	C
1	ITEM	ID	QTY
2	BS-TA-107	QQW-8 CLA8 UK	456.000
3	BS-TA-108	QQW-9 CLA9 N BR	600.000
4	BS-TA-113	QQW-14 L/R CLA14 SS230 EG	12.000
5	BS-TA-117	QQW-18 RRSDF BR	234.000
6	BS-TA-118	QQW-19 CLA19 IT	400.000
7	BS-TA-119	QQW-20 KV/1**2 CLA20 CHI	123.000
REPORT

file pur2

PUR2.xlsx
	A	B	C
2	BS-TA-103	QQW-4 M*12.5 CLA4 TR	100.000
3	BS-TA-104	QQW-5 CLA5 EG	120.000
4	BS-TA-105	QQW-6 M230 TU	501.000
5	BS-TA-106	QQW-7 S** CLA7 US	200.000
6	BS-TA-107	QQW-8 CLA8 UK	120.000
DATA

with considering I have many sheets for each file

 

[mumps]

Place this macro in the SEARCH workbook. Change the sheet name (in blue) and the folder path where the files are saved (in red) to suit your needs.

Sub MatchData()
    Application.ScreenUpdating = False
    Dim desWB As Workbook, srcWS As Worksheet, arr1 As Variant, arr2 As Variant, lRow As Long
    Dim dic As Object, srcRng As Range, x As Long, ws As Worksheet
    Set srcWS = ThisWorkbook.Sheets("RP")
    With srcWS
        arr1 = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2).Value
        Set srcRng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set desWB = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            With ws
                arr2 = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2).Value
                Set dic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(arr1, 1)
                    If Not dic.Exists(arr1(i, 1)) Then
                        dic.Add arr1(i, 1), Nothing
                    End If
                Next i
                For i = 1 To UBound(arr2, 1)
                    If dic.Exists(arr2(i, 1)) Then
                        If Not IsError(Application.Match(arr2(i, 1), srcRng, 0)) Then
                            x = Application.Match(arr2(i, 1), srcRng, 0)
                            ws.Range("B" & i + 1).Value = srcWS.Range("B" & x + 1).Value
                        End If
                    End If
                Next i
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Range("D2").FormulaR1C1 = "=MID(RC[-3],FIND(""-"",RC[-3])+1,99999)"
                .Range("D2").AutoFill Destination:=.Range("D2:D" & lRow), Type:=xlFillDefault
                .Range("D2:D" & lRow).Value = .Range("D2:D" & lRow).Value
                .Cells(1, 4).Sort Key1:=.Columns(4), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
                .Columns(4).Delete
                dic.RemoveAll
            End With
        Next ws
        With ActiveWorkbook
            .Save
            .Close False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Hasson]

great code. just question if you have free time. the code works for multiple sheets for each file . I would another choice by making the code for one sheet for each file

each file just contains sheet1 , how can I mod the code, please ?

 

[mumps]

The code should work without any changes as long as each file contains only one sheet so you can use it for any number of sheets including just one.

 

[Hasson]

thanks very much for your following my thread and provide me big favor

 

[mumps]

You are very welcome.