2 Replies Latest reply on Jul 30, 2018 8:38 AM by Robert Voogt

    BOM in Excel, find pdf files and place in another folder.

    Robert Voogt

      Hi all,

       

      This is more of an Excel VBA question. I have exported the BOM list from PDM and I have written a Macro that deletes all unimportant information from that file.

      I end up with a list of only the part numbers I need:

      Example:

       

      FM.00.620.004

      SA00078195

      SA00110545
      SA00100546
      SP.00.103.123
      SA00051007

       

      I need the macro to search for each row the corresponding pdf file (solidworks drawing) in folder "Released Drawings" and then copy/paste them all in folder B. (best is if that folder is being created in a certain location with the value of the FM row)

       

      The pdf files have the following names: (for example)

       

      FM.00.620.004_C.pdf

      SA00078195_A.pdf

      SA00110545_D.pdf
      SA00100546_A.pdf
      SP.00.103.123_A.pdf
      SA00051007_B.pdf

       

      So it needs to look for the latest version of a file (when a file ends with _D, there is also a _C variant. It needs to select the D variant. it will also have the newest date)

       

       

      Update 1, made the create folder myself with (in a loop):

                If InStr(StrConv(ActiveCell, vbUpperCase), "FM") = 1 Then         

                Fldr_name = "D:\Spare Part Generator\MRD Final\" & ActiveCell

                FSO.CreateFolder (Fldr_name)

        • Re: BOM in Excel, find pdf files and place in another folder.
          Robert Voogt

          And here the code:

           

           

          Public FSO As New FileSystemObject
          Sub MARS_FRS()
          '
          ' MARS_FRS Macro
          ' File Retrieval System
          '
          ' Keyboard Shortcut: Ctrl+m
          '
            
              Dim lLoop As Long
              Dim rFoundCell As Range
              Dim nRow As Integer
              Dim u As Integer
              Dim v As Integer
              Dim objFolder As Folder
              Dim objFile As File
              Dim fitem As String
              Dim Fldr_name As String
              Dim MRD_Fldr As String
              
              MRD_Fldr = "D:\Spare Part Generator\Manuals Release Drawings\"
              
              
              ' Selecting range
              
              nRow = Worksheets(ActiveSheet.Name).Range("A1").End(xlDown).Row
              u = 0
              v = 1
              ' Deleting all columns besides column D
              
              Set rRng = Sheet1.Range("B1")
              If IsEmpty(rRng.Value) Then
              Else
              Columns("A:C").Select
              Selection.Delete Shift:=xlToLeft
              Columns("B:K").Select
              Selection.Delete Shift:=xlToLeft
              Range("A1").Select
              End If
              
              ' Find all cells containing SA, IE, FM, SP and placing them in correct folder
              
              'Starting position
              Range("A1").Select
              
              'Keep looping until the activecell is empty.
              Do Until u = nRow
                  
                  u = u + 1
                  
                  If InStr(StrConv(ActiveCell, vbUpperCase), "SA") = 1 Then
                  '...move down a cell.
                  ActiveCell.Offset(1, 0).Select
                  Else
                      If InStr(StrConv(ActiveCell, vbUpperCase), "FM") = 1 Then
                      v = v + 1
                          ' check to find only the first FM in case there are multiple
                          If v = 2 Then
                          Fldr_name = "D:\Spare Part Generator\MRD Final\" & ActiveCell
                              If (FSO.FolderExists(Fldr_name)) Then
                              Else
                              FSO.CreateFolder (Fldr_name)
                          End If
                          Else
                          End If
                      ActiveCell.Offset(1, 0).Select
          
          
                      Else
                          If InStr(StrConv(ActiveCell, vbUpperCase), "IE") = 1 Then
                          ActiveCell.Offset(1, 0).Select
                          Else
                              If InStr(StrConv(ActiveCell, vbUpperCase), "SP") = 1 Then
                              ActiveCell.Offset(1, 0).Select
                              Else
                              ActiveCell.ClearContents
                              Selection.Delete Shift:=xlUp
                              End If
                              
                          End If
                          
                      End If
              
                  End If
          
          
              Loop
              
             
              ' Save
              
              'ActiveWorkbook.Save
              
          End Sub
          
            • Re: BOM in Excel, find pdf files and place in another folder.
              Robert Voogt

              Solved it:

               

              ' *******************************************************************************
              ' Manual Access & Retrieval System --- MARS --- By Robert Voogt ---
              ' *******************************************************************************
              ' File Retrieval System --- FRS
              ' *******************************************************************************
              '
              '
              ' *What does it do?*
              '
              ' It first converts the exported BOM list to only show the needed assemblies
              ' and their revisions
              ' It then will search and find the files in the origin folder and places them
              ' in a correctly named folder
              '
              ' Keyboard Shortcut: Ctrl+m
              '
              ' *******************************************************************************
              
              
              Public fso As New FileSystemObject
              Sub MARS_FRS()
                
                  Dim lLoop As Long
                  Dim rFoundCell As Range
                  Dim nRow As Integer
                  Dim u As Integer
                  Dim v As Integer
                  Dim objFolder As Folder
                  Dim objFile As file
                  Dim fitem As String
                  Dim Fldr_name As String
                  Dim fso As Object
                  Dim Origin As String
                  
                  u = 0
                  v = 1
                  
                  Set fso = VBA.CreateObject("Scripting.FileSystemObject")
                  Origin = "D:\Spare Part Generator\Manuals Release Drawings\"
                  Fldr_name = "D:\Spare Part Generator\MRD Final" 'Destination
              
              
              
              
                  ' Selecting range
                  If IsEmpty(Range("A1").Value) = True Then
                  Else
                  nRow = Worksheets(ActiveSheet.Name).Range("A1").End(xlDown).Row
                  End If
                  
                  ' Deleting all columns besides column D
                  
                  If IsEmpty(Range("L1").Value) = True Then
                  Else
                  Columns("A:C").Select
                  Selection.Delete Shift:=xlToLeft
                  Columns("B").Select
                  Selection.Delete Shift:=xlToLeft
                  Columns("C:J").Select
                  Selection.Delete Shift:=xlToLeft
                  Range("A1").Select
                  End If
              
                  
                  ' Find all cells containing SA, IE, FM, SP and placing them in correct folder
                  
                  'Starting position
                  
                  Range("A1").Select
                  
                  'Keep looping until the activecell is empty.
                  
                  Do Until u = nRow
                      file = Dir(Origin)
                      
                      
                      u = u + 1
                      
                      If InStr(StrConv(ActiveCell, vbUpperCase), "SA") Or InStr(StrConv(ActiveCell, vbUpperCase), "IE") Or InStr(StrConv(ActiveCell, vbUpperCase), "SP") Or InStr(StrConv(ActiveCell, vbUpperCase), "FM") Then
                          
                          If InStr(StrConv(ActiveCell, vbUpperCase), "FM") = 1 Then
                          v = v + 1
                          ' check to find only the first FM in case there are multiple
                              If v = 2 Then
                              Fldr_name = "D:\Spare Part Generator\MRD Final\" & ActiveCell
                                  If (fso.FolderExists(Fldr_name)) Then
                                  Else
                                  fso.CreateFolder (Fldr_name)
                                  End If
                              Else
                              End If
                          End If
                          
                          'Copy file
                      While (file <> "")
                          If InStr(file, ActiveCell) > 0 Then
                          FileCopy Origin & file, Fldr_name & "\" & file
                          End If
                      file = Dir
                      Wend
              
              
                      ActiveCell.Offset(1, 0).Select
                      
                      Else
                      
                      ActiveCell.ClearContents
                      ActiveCell.EntireRow.Select
                      Selection.Delete Shift:=xlUp
                               
                      End If
              
              
                  Loop
                  
                 
                  ' Save
                  
                  'ActiveWorkbook.Save
                  'ActiveWorkbook.Close
                  
              End Sub