copy data based on part of item when matching more than 34 sheets and invert value for one item

[MKLAQ]

Hi experts ,
I need macro for about 4000 rows for each sheet and about more than 34 sheets when matching part of item across sheets
so the parts of items waht I want matching across sheets are
(CCS DEL,MASROUFA FGRTERE,SSMT TRYU,PTT REF)
then should copy data to FTT sheet start arrainging date fro old to last with sort items from A-Z and invert the value for just SSMT TRYU from column D to column C and delete any characters before or after parts of items as show the result in FFT sheet and should deal any new data or change in others sheets without repeat copying data have already copied.

MK.xlsm
	A	B	C	D
1	DATE	ID	BUYING	SELLING
2
3
4
5
6
7
8
9
FTT

MK.xlsm
	A	B	C	D
1	DATE	ID	BUYING	SELLING
2	07/20/2023	CCS DEL CCR1-CMB1 G80000	233
3	07/20/2023	CCCH Y8888 HJJJ 7000LM	123
4	02/21/2023	CCS DEL CVBBBB20000 NMUI 345000	124
5	02/21/2023	CVBBBB20000 NMUI 345001	123	2
6	02/21/2023	CVBBBB20000 NMUI 345002	44	3
7	02/21/2023	MASROUFA FGRTERE 80000 JKHHGTTT100		4
8	02/22/2023	HGJGG PTT REF FGRTERE 90000 4555	66
9	02/23/2023	SSMT TRYU CCR1-CMB8BB NMJ7000		700
10	02/24/2023	PTT REF MNDFHHHH 50000 JK900	88
ASH

MK.xlsm
	A	B	C	D
1	DATE	ID	BUYING	SELLING
2	07/20/2023	CCS DEL CCR1-CMB1 G180000	50
3	07/20/2023	CCCH Y8888 HJJJ 17000LM	123
4	07/20/2023	CVBBBB20000 123NMUI 345000	11
5	07/20/2023	CVBBBB20000 NMUIGH34 345001	22	2
6	02/21/2023	TRYCVBBBB20000 NMUI 345002	11	3
7	02/21/2023	SSMT TRYU NMJFRTERE 80000 JKHHGTTT100		4
8	02/21/2023	MTHYHGJGG FGRTERE 90000 4555	23
9	02/21/2023	ASDFFCCR1-CMB8BB NMJ7000	77
10	02/21/2023	MNDFHHHH 50000 JK900 PTTTR500	23
GHF2

result should be

MK.xlsm
	A	B	C	D
1	DATE	ID	BUYING	SELLING
2	07/20/2023	CCS DEL	233
3	07/20/2023	CCS DEL	50
4	02/21/2023	CCS DEL	124
5	02/21/2023	MASROUFA FGRTERE		4
6	02/21/2023	SSMT TRYU	4
7	02/22/2023	PTT REF	66
8	02/23/2023	SSMT TRYU	700
9	02/24/2023	PTT REF	88
FTT

 

[Akuini]

and should deal any new data or change in others sheets without repeat copying data have already copied.

I don't understand this part, can you give an example?

 

[MKLAQ]

Hi,
in other meaning : should clear data in FTT sheet before bring data when run the macro every time to make sure for prevention to repeat copying data have already copied every time running the macro .

 

[RudRud]

Book2
	A	B	C	D	E	F	G
1	DATE	ID	BUYING	SELLING			CCS DEL
2	7/20/23	CCS DEL	233				MASROUFA FGRTERE
3	7/20/23	CCS DEL	50				SSMT TRYU
4	2/21/23	CCS DEL	124				PTT REF
5	2/21/23	MASROUFA FGRTERE		4
6	2/24/23	PTT REF	88
7	2/22/23	PTT REF	66
8	2/23/23	SSMT TRYU		700
9	2/21/23	SSMT TRYU		4
FTT

FYR,

Please give a shot @MKLAQ, In order to run the code, you must add list keyword in sheets FTT column G

Option Compare Text
Option Explicit
Sub test()
'Dim dict As New Dictionary
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim ws As Worksheet
Set ws = Sheets("FTT")
Dim b As Variant, arrwords As Variant, a As Variant, aword As Variant
Dim K%, i%, c%

ReDim b(1 To 100000, 1 To 4)
'store column G key words
With ws
    arrwords = .Range("g1:g" & .Cells(Rows.Count, "g").End(xlUp).Row).Value
End With

'Loop through Workbook Worksheets
For K = 1 To Worksheets.Count
    If Sheets(K).Name <> "FTT" Then
        With Sheets(K)
            a = .Range("a2:d" & .Cells(Rows.Count, "a").End(xlUp).Row).Value 'Store Sheets Value to array
          
                For i = 1 To UBound(a, 1)
                    For Each aword In arrwords 'loop through each keyword
                        If InStr(a(i, 2), aword) > 0 Then 'If found then row 2 putkeyword
                            c = c + 1
                            b(c, 1) = a(i, 1)
                            b(c, 2) = aword
                            b(c, 3) = a(i, 3)
                            b(c, 4) = a(i, 4)
                            Exit For
                        End If
                    Next
                Next i
        End With
    End If
Next K

With ws 'Sheet FTT
    .[a2:d500000].ClearContents
    .[a2].Resize(UBound(b, 1), UBound(b, 2)).Value = b
    .[a2].Sort Key1:=Range("b2"), key2:=Range("a2"), order1:=xlAscending, order2:=xlDescending, Header:=xlYes
End With

End Sub

 

[RudRud]

Adjustment:

Option Compare Text
Option Explicit
Sub test()
'Dim dict As New Dictionary
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim ws As Worksheet
Set ws = Sheets("FTT")
Dim b As Variant, arrwords As Variant, a As Variant, aword As Variant
Dim K%, i%, c%

ReDim b(1 To 100000, 1 To 4)

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'store column G key words
With ws
    arrwords = .Range("g1:g" & .Cells(Rows.Count, "g").End(xlUp).Row).Value
End With

'Loop through Workbook Worksheets
For K = 1 To Worksheets.Count
    If Sheets(K).Name <> "FTT" Then
        With Sheets(K)
            a = .Range("a2:d" & .Cells(Rows.Count, "a").End(xlUp).Row).Value 'Store Sheets Value to array
         
                For i = 1 To UBound(a, 1)
                    For Each aword In arrwords 'loop through each keyword
                        If InStr(a(i, 2), aword) > 0 Then 'If found then row 2 putkeyword
                            c = c + 1
                            b(c, 1) = a(i, 1)
                            b(c, 2) = aword
                            b(c, 3) = a(i, 3)
                            b(c, 4) = a(i, 4)
                            Exit For
                        End If
                    Next
                Next i
        End With
    End If
Next K

With ws 'Sheet FTT
    .[a2:d500000].ClearContents
    .[a2].Resize(UBound(b, 1), UBound(b, 2)).Value = b
    .[a2].Sort Key1:=Range("b2"), key2:=Range("a2"), order1:=xlAscending, order2:=xlDescending, Header:=xlYes
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[MKLAQ]

@RudRud
your code is great!
I have two things
I would for you to see in result for row6,8 is not as what i want and I said

and invert the value for just SSMT TRYU from column D to column C

second I'm surprised from your code is not fast with simple data as in OP . seem slight slow , despite of use array & dic
now I'm not at work to test with multiple sheets and much rows , but I will test it tomorrow at work and see how goes.
but the running speed gives 1.00 sec with simple data
thank you .

 

[RudRud]

Book2.xlsb
	A	B	C	D
1	DATE	ID	BUYING	SELLING
2	7/20/23	CCS DEL	233
3	7/20/23	CCS DEL	50
4	2/21/23	CCS DEL	124
5	2/21/23	MASROUFA FGRTERE		4
6	2/24/23	PTT REF	88
7	2/22/23	PTT REF	66
8	2/23/23	SSMT TRYU	700
9	2/21/23	SSMT TRYU	4
FTT

Hi @MKLAQ, I've changed ssmt tryu from d to c.

Actually I'm only working with array with Instr, that's why take more time to execute the code,

Hopefully there's other gurus can provide other solutions which's more efficiency

Option Compare Text
Option Explicit
Sub test()
'Dim dict As New Dictionary
'Dim dict As Object
'Set dict = CreateObject("Scripting.Dictionary")
'dict.CompareMode = vbTextCompare
Dim ws As Worksheet
Set ws = Sheets("FTT")
Dim b As Variant, arrwords As Variant, a As Variant, aword As Variant
Dim K%, i%, c%

ReDim b(1 To 100000, 1 To 4)

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'store column G key words
With ws
    arrwords = .Range("g1:g" & .Cells(Rows.Count, "g").End(xlUp).Row).Value
End With

'Loop through Workbook Worksheets
For K = 1 To Worksheets.Count
    If Sheets(K).Name <> "FTT" Then
        With Sheets(K)
            a = .Range("a2:d" & .Cells(Rows.Count, "a").End(xlUp).Row).Value 'Store Sheets Value to array
        
                For i = 1 To UBound(a, 1)
                    For Each aword In arrwords 'loop through each keyword
                        If InStr(a(i, 2), aword) > 0 Then 'If found then row 2 putkeyword
                            c = c + 1
                            b(c, 1) = a(i, 1)
                            b(c, 2) = aword
                            If aword = "SSMT TRYU" Then
                                b(c, 3) = a(i, 4)
                                Exit For
                            Else
                                b(c, 3) = a(i, 3)
                            End If
                            b(c, 4) = a(i, 4)
                            Exit For
                        End If
                    Next
                Next i
        End With
    End If
Next K

With ws 'Sheet FTT
    .[a2:d500000].ClearContents
    .[a2].Resize(UBound(b, 1), UBound(b, 2)).Value = b
    .[a2].Sort Key1:=.Range("b2"), key2:=.Range("a2"), order1:=xlAscending, order2:=xlDescending, Header:=xlYes
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[MKLAQ]

Hi @MKLAQ, I've changed ssmt tryu from d to c.

thanks again , but gives mismatch error in this line

For Each aword In arrwords

Hopefully there's other gurus can provide other solutions which's more efficiency

I know you do your best & thank you
I hope from experts see this thread and share us faster code

 

[RudRud]

thanks again , but gives mismatch error in this line

For Each aword In arrwords

I know you do your best & thank you
I hope from experts see this thread and share us faster code

Did you put keyvalue in Column G Sheets FTT?

I tried run 38sheets (each sheet around 4k rows) , it takes roughly 5-10second (macos)

Meanwhile Dim c as long ( instead of integer)

 

[MKLAQ]

ok I will check my bad and comeback here.
thanks