Consulting

Results 1 to 5 of 5

Thread: Creation of File list in a new Workbook

  1. #1
    VBAX Regular
    Joined
    Dec 2019
    Posts
    8
    Location

    Creation of File list in a new Workbook

    I have an excel VBA code that:
    1. uses cell information (in sheet 2) to create a directory folder structure
    2. uses cell information to place the correct file to the correct foolder (that was previously created)
    3. renames the files when 255 characters are exceeded
    4. when there are both native files (i.e. excel, word, autocad) and pdf files of the same file these are place in sheet 3 (named attachments)
    5. Creates a hyperlink in the forth tab when the files have been moved succesfully
    6. the excel

    I need your help for the following because i have no clue where to start from

    The above is an everyday task and i need a new excel to be generated everytime new documents are received and placed to the right place, with the exact format of the Sheet2 and sheet 3 (attachments) that will have all the past and present files with the addition of a hyperlink to the last column


    Public CopyingFilesNo As IntegerPublic Function IsFolderExists(txt As String) As Boolean
    
    
    'returns true if the folder exists already, false if it does not.
    IsFolderExists = CreateObject("Scripting.FileSystemObject").FolderExists(txt)
        
    End Function
    
    
    Sub file_move()
    On Error GoTo ErrorHandler:
    
    
    Dim myFile As String
    Dim myPath As String 'folder to test
    Dim myPaths 'to check each folder in the destination path
    Dim i As Long, j As Integer, CountF As Integer
    Dim ws As Worksheet 'sheet with data
    Dim wsSV As Worksheet 'sheet to update
    Dim lr As Long 'last row with data
    Dim baseFolder As String
    Dim SourceFolder As String
    
    
    
    
    Dim Folder1 As String
    Dim TempFolder As String
    
    
    
    
    Dim Folder2 As String
    Dim Folder2Plus As String
    
    
    Dim tempFolderTwo As String
    Dim subFolderTwo As String
    
    
    Dim Folder3 As String
    Dim Folder3Plus As String
    
    
    
    
    Dim tempFolderThree As String
    Dim subFolderThree As String
    
    
    Dim Folder4 As String
    Dim Folder4Plus As String
    
    
    Dim tempFolderFour As String
    Dim subFolderFour As String
    
    
    Dim FileName As String
    Dim FIleNameNew As String
    Dim FileNameFinal As String
    
    
    Dim CheckString As String
    Dim Cnt As Integer
    Dim rng As Range
    
    
    baseFolder = "W:\GR-IPP_II\03. Procurement\03. EQUIPMENT\GE\"
    SourceFolder = "W:\GR-IPP_II\03. Procurement\03. EQUIPMENT\GE"
    
    
    Set ws = Worksheets("Sheet2") 'change sheet name as needed
    Set wsSV = Worksheets("DocumentList")
    lr = ws.Range("A" & Rows.Count).End(xlUp).Row
    Cnt = 1
    CopyingFilesNo = 0
    For i = 2 To lr
    'Update*******************************************
        Cnt = Worksheets("DocumentList").UsedRange.Rows.Count
        Set rng = wsSV.Range("A" & Cnt + 1)
    '*************************************************
        
        myPath = Replace(ws.Range("C" & i).Value, "/", "-")
        myPaths = Split(myPath, "\")
        myPath = vbNullString
        Folder1 = Trim(ws.Range("A" & i).Value)
        
        Dim fso As New FileSystemObject
       If fso.FolderExists(baseFolder + Folder1) = False Then
            fso.CreateFolder baseFolder + "" + Folder1
       End If
          
      '*********************************
        
        
        Folder2 = Replace(ws.Range("c" & i).Value, "/", "")
        Folder2Plus = Replace(ws.Range("d" & i).Value, "/", "")
        
        tempFolderTwo = Trim(Folder2) + " " + Trim(Folder2Plus)
       
       
       If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo) = False Then
            fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo)
       End If
       
       '************************************************************************
       
        
        Folder3 = Replace(ws.Range("e" & i).Value, "/", "")
        Folder3Plus = Replace(ws.Range("f" & i).Value, "/", "")
        
        tempFolderThree = Trim(Folder3) + " " + Trim(Folder3Plus)
       
       
       If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree) = False Then
            fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree)
       End If
       '************************************************************************
       
    
    
        
        Folder4 = Replace(ws.Range("g" & i).Value, "/", "")
        Folder4Plus = Replace(ws.Range("h" & i).Value, "/", "")
        
        tempFolderFour = Trim(Folder4) + " " + Trim(Folder4Plus)
       
       
       If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour) = False Then
            fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour)
       End If
       '************************************************************************
       
       FileName = Replace(ws.Range("AE" & i).Value, "/", "")
       CheckString = baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\" + FileName
       If Len(CheckString) > 255 Then
          Dim diff As Integer
          diff = Len(CheckString) - 255
          If fso.FileExists(SourceFolder + "\" + FileName) = True Then
              FIleNameNew = Mid(FileName, 1, Len(FileName) - 5 - diff) + Mid(FileName, Len(FileName) - 4, 5)
              fso.MoveFile SourceFolder + "\" + FileName, SourceFolder + "\" + FIleNameNew
              FileNameFinal = baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\" + FIleNameNew
              Call CopyFiles(SourceFolder, FIleNameNew, FileNameFinal)
              wsSV.Range("A" & Cnt + 1) = FileNameFinal
              wsSV.Range("B" & Cnt + 1) = FileName
              wsSV.Range("C" & Cnt + 1) = ws.Range("v" & i).Value
              wsSV.Range("D" & Cnt + 1) = ws.Range("t" & i).Value
              wsSV.Hyperlinks.Add wsSV.Range("A" & Cnt + 1), FileNameFinal
          End If
       Else
         FileNameFinal = CheckString
        'Call fso.CopyFile(SourceFolder + "\" + FileName, FileNameFinal, True)
        If CopyFiles(SourceFolder, FileName, FileNameFinal) = True Then
         ws.Range("AZ" & i).Value = True
          Call WriteToDocumentList(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\", FileName, ws.Range("v" & i).Value, ws.Range("t" & i).Value)
     
         End If
        
        
      
        
       End If
       
      
    
    
       
       '**********************************
       If (ws.Range("af" & i).Value) <> 0 Then
       CountF = 1
       For CountF = 1 To ws.Range("af" & i).Value
         Call AddAttachments(ws.Range("t" & i).Value, CountF, baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\", SourceFolder)
        Next CountF
       End If
       
    Next i
    
    
    MsgBox "FILES COPIED:" & CopyingFilesNo & " Files", vbInformation
     Exit Sub
    ErrorHandler:
      MsgBox Err.Number & vbCrLf & FileName & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorInput"
    End Sub
    
    
    Private Function AddAttachments(FileIndex As String, Current As Integer, FileDestination As String, SourceFolder As String) As Boolean
    On Error GoTo ErrorHandler:
    Dim wsAtcm As Worksheet
    Dim lRow As Long
     Dim rangeAtcm As Range
     Dim FoundCell As Range
     Dim FileNametcm As String
     Dim wsSV As Range
    
    
    ' Set wsSV = Worksheets("DocumentList")
    
    
    Set wsAtcm = Worksheets("Attachments")
    
    
     Set rangeAtcm = wsAtcm.Range("A1")
    
    
    Set FoundCell = wsAtcm.Range("B:B").Find(what:=FileIndex, lookat:=xlWhole)
    FileNametcm = rangeAtcm.Range("I" & FoundCell.Row).Value
    rangeAtcm.Range("B" & FoundCell.Row).Value = rangeAtcm.Range("B" & FoundCell.Row).Value & " Copied"
     
     Call CopyFiles(SourceFolder, FileNametcm, FileDestination & FileNametcm)
     Call WriteToDocumentList(FileDestination, FileNametcm, rangeAtcm.Range("D" & FoundCell.Row).Value, FileIndex)
     AddAttachments = True
     Exit Function
    ErrorHandler:
      MsgBox Err.Number & vbCrLf & FileNametcm & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorAttachm"
    
    
    End Function
    
    
    Private Function CopyFiles(SourcePath As String, FileName As String, DestinationPath As String) As Boolean
    Dim fso As New FileSystemObject
    Dim NewStringSource As String
    Dim NewDestinationPath As String
    On Error GoTo ErrorHandler:
    NewStringSource = SourcePath + "\" + FileName
    NewDestinationPath = DestinationPath
    If InStr(SourcePath + "\" + FileName, "®") Then
    
    
     NewStringSource = Replace(SourcePath + "\" + FileName, "®", "")
     fso.MoveFile SourcePath + "\" + FileName, NewStringSource
      
     NewDestinationPath = Replace(DestinationPath, "®", "")
    End If
    
    
     Call fso.CopyFile(NewStringSource, NewDestinationPath, True)
     fso.DeleteFile (NewStringSource)
     CopyingFilesNo = CopyingFilesNo + 1
     CopyFiles = True
     
     Exit Function
    ErrorHandler:
      MsgBox Err.Number & vbCrLf & FileName & vbCrLf & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorcOPYING"
    End Function
    
    
    Private Sub WriteToDocumentList(DestinationPath As String, FileName As String, RevisionDate As String, DocumentNumber As String)
    Dim Cnt As Integer
    Dim wsSV As Worksheet
    Dim rng As Range
    On Error GoTo ErrorHandler:
    Set wsSV = Worksheets("DocumentList")
    
    
    Cnt = 0
       Cnt = Worksheets("DocumentList").UsedRange.Rows.Count
        Set rng = wsSV.Range("A" & Cnt + 1)
            wsSV.Range("A" & Cnt + 1) = DestinationPath & FileName
        wsSV.Range("B" & Cnt + 1) = FileName
        wsSV.Range("C" & Cnt + 1) = RevisionDate
        wsSV.Range("D" & Cnt + 1) = DocumentNumber
        wsSV.Hyperlinks.Add wsSV.Range("A" & Cnt + 1), DestinationPath
    Exit Sub
    ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "ErrorWrite"
    End Sub
    Attached Files Attached Files

  2. #2
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    Hello santh,

    Perhaps this issue is on my end. I have downloaded your workbook twice and each time the workbook opens, there are no worksheets.
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  3. #3
    VBAX Regular
    Joined
    Dec 2019
    Posts
    8
    Location
    Hello Leith! and thank you for your response
    i attached it as a zip. If you want to try again
    Attached Files Attached Files

  4. #4
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    Hello santh,

    Thank you for the zip file. I was able to open the workbook with no problems.
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  5. #5
    VBAX Regular
    Joined
    Dec 2019
    Posts
    8
    Location
    Thank you for trying! Please let me know if i didn't explain well the problem. Reading my thread again makes me wonder

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •