USEFUL VBA

SOME RANDOM VBA CODES CAN BE USED AS NEEDED

NOTE: Use, only if you have a good VBA coding experience.

 -------------------------------------------------------
Sub BOM_ASFAR() 'THIS MACRO COPY'S "PROFILE" TO FIND FILE WORKBOOK
     

        'Application.ScreenUpdating = False

     

        Dim myFile As String, myPath As String, 
        myExtension As String

        Dim wb As Workbook

        Dim i As Long, k As Long

        Dim iLastRow As Long, kLastRow As Long

        Dim myValue As Variant

        Const StartRow As Byte = 10

        Dim mystore As Double

 

        myPath = "E:\Redirect\un.singh\Desktop\BOM\"

        myExtension = "*.xls*"

        myFile = Dir(myPath & myExtension)

    Dim xRet As Boolean

    xRet = IsWorkBookOpen(myFile)

    If xRet = False Then

    Do While myFile <> ""

 

    On Error Resume Next

   

    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    wb.Worksheets("ASSEMBLY_LIST").Select

'Start:

        iLastRow = Range("A" & StartRow).End(xlDown).Row

        kLastRow = Range("K" & StartRow).End(xlDown).Row

        For k = StartRow To kLastRow

        For i = StartRow To iLastRow

     

        myValue = Range("C" & i).Value

                If myValue = Range("K" & k).Value Then

                mystore = mystore + Range("H" & i).Value

                Else

                End If

        Next i

        Range("P" & k).Value = mystore

           

        mystore = 0

        Next k

                   

         Call Macro14

             

        Application.CutCopyMode = False

       ' If myFile <> "DP16004-CS-PBOM-1137A_R0_20190603 (VBA Platform).xlsm" Then    'NEW

        wb.Close savechanges:=True

       ' Else      'NEW

       ' End If    'NEW

             

    myFile = Dir()

    Loop

 

    Call Macro13

Else

    'Worksheets("ASSEMBLY_LIST").Select

    'GoTo Start

    MsgBox "pl close file BOM"

End If

 

   'Application.ScreenUpdating = True

End Sub

Sub Macro13() ' SHALL BE USED WITH MACRO "myFileopen1" SEE ABOVE

' Macro13 Macro

'1)REMOVE DUPLICATE PROFILES

    Sheets("Sheet2").Select

    Range("A3").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    ActiveWindow.SmallScroll Down:=-78

    Range("H3").Select

    ActiveSheet.Paste

    Application.CutCopyMode = False

    Range("H3").Select

    ActiveSheet.Range(Selection, Selection.End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes

'2)CONSOLIDATE WT OF "F" AND WRITE IN COLOUMN "I"

    Dim myFile As String

    Dim i As Long, h As Long

    Dim iLastRow As Long, hLastRow As Long

    Dim myValue As Variant

    Const StartRow As Byte = 3

    Dim mystore As Double

    iLastRow = Range("A" & StartRow).End(xlDown).Row

    hLastRow = Range("H" & StartRow).End(xlDown).Row

 

For h = StartRow To hLastRow

        For i = StartRow To iLastRow

                myValue = Range("A" & i).Value

                If myValue = Range("H" & h).Value Then

                    mystore = mystore + Range("A" & i).Offset(, 5).Value

                Else

                End If

        Next i

     

        Range("I" & h).Value = mystore

        mystore = 0

Next h

End Sub

Sub Macro14() ' SHALL BE USED WITH MACRO "myFileopen1" SEE ABOVE

' Macro13 Macro

    Range("K8").Select

    Selection.End(xlDown).Select

    Range(Selection, Selection.End(xlDown)).Select

    Range(Selection, Selection.End(xlToRight)).Select

    Selection.Copy

 

    Windows("FINDFILE.xlsm").Activate

   

    Range("A1").Select

    Selection.End(xlDown).Select

    Selection.Offset(1, 0).Select

 

    ActiveSheet.Paste

 

End Sub

 ---------------------------------------------------------------------------
the output looks like below-

data collected and consolidated from such several files which are in a specific folder-