Looking for VBA to help with data collection

E

ExcelNewbie2009

New Member
Joined
Jun 28, 2022
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Provide for the coders:
  1. Version of the program
    1. Microsoft 365 MSO (Version 2204 Build 16.0.15128.20278) 64-bit
  2. What you want it to do
    1. I would like to derive data from the files within a folder, and perform the writing functions within excel, as I have listed below in my screenshot:
    2. 1656429003739.png
  3. I have VBA code that does parts of what I need, but since I added more columns and renamed columns, all the links are pretty much broken (attaching the code for your review).

I have very limited knowledge when it comes to writing VBA, so any and all help would be greatly appreciated, even if code needs to be re-written.

VBA Code: 
Option Explicit
    Public xFSO, xFolder, t3 As Object
    Public xFile, xFileF, xSubFolder As Object
    Public myFolderName, toAddress, toJob, ProjectNum, Notes, toAttn, code As String
  
Sub TransmittalsIn()
    ActiveSheet.Shapes("Arrow-OUT").Visible = False
    ActiveSheet.Shapes("Arrow-IN").Visible = False
    ActiveSheet.Shapes("Cross1").Visible = True
      
    Dim xFiDialog As FileDialog
    Dim i, r, DeleteRows, SIC As Integer
    Dim Tran, xPath, countfile, ypath As String
  
On Error GoTo GameOver
Application.ScreenUpdating = False
  
    Worksheets("LOG").Activate
  
'        REV = InputBox(Prompt:="Enter Rev #", Title:="Rev #", Default:="0")
'           If REV = vbNullString Then Exit Sub
          
        code = InputBox(Prompt:="Enter Transmittal Code.", Title:="Transmittal Code", Default:="Approved")
            If code = vbNullString Then Exit Sub
          
    Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
      
        With xFiDialog
            .InitialFileName = ThisWorkbook.Path & "\IN"
            .AllowMultiSelect = False
                If .Show = -1 Then xPath = xFiDialog.SelectedItems(1)
        End With
      
    Set xFiDialog = Nothing
      
        If xPath = "" Then Exit Sub
            Set xFSO = CreateObject("Scripting.FileSystemObject")
            Set xFolder = xFSO.GetFolder(xPath)
       
' Count the number of files
        ypath = xPath & "\*.*"
        countfile = Dir(ypath)
        Do While countfile <> ""
            SIC = SIC + 1
            countfile = Dir()
        Loop
i = 0
MsgBox "File Count = " & SIC, vbOKOnly

        Range("A5").End(xlDown).Select
            If ActiveCell().Value <> "" Then
                    Worksheets("LOG").ListObjects("Trans").ListRows.ADD               ' Adds a new row to the table
                    ActiveCell().Offset(1).Select
                Else
                    ActiveCell.Offset(-1).Select
            End If
      
    For Each xFile In xFolder.Files
            i = i + 1
            ActiveSheet.Hyperlinks.ADD ActiveCell(i, 1), xFolder.Path, TextToDisplay:=xFolder.Name 'A - Transmittal # -- ' Hyperlink to folder, uses folder name as display text -options: xFile.Path, xFile.Name
                        'trimmer xFolder.Path
            ActiveCell(i, 2).Formula = "=IF([@[Transmittal Code]]<>""A"",LOOKUP(2,1/([Team File Name]&[Revision '#]&[Transmittal Code]=[@[Team File Name]]&[@[Revision '#]]&""A""),"""")"
            ActiveCell(i, 3) = xFile.Name  'C - Team File Name                                              ' returns filename and extension -- xFile.BaseName - returns just the filename
            ActiveCell(i, 4) = UCase(code) 'D - Transmittal Code                                            ' Transmittal Code
            ActiveCell(i, 5).Formula = "=IF([@[Transmittal Code]]<>""A"",LOOKUP(2,1/([Team File Name]&[Transmittal Code]=[@[Team File Name]]&""A""),([Revision '#])),"""")"         'E - Revision #                                                  ' Document Rev #
            ActiveCell(i, 6).Formula = "=IF([@[Transmittal Code]]="""","""",LOOKUP(2,1/([Team File Name]&[Revision '#]=[@[Team File Name]]&[@[Revision '#]]),([Transmittal Code])))" 'F - Status
            ActiveCell(i, 7).Formula = "=IF([@[Transmittal Code]]<>""A"",LOOKUP(2,1/([Team File Name]&[Revision '#]&[Transmittal Code]=[@[Team File Name]]&[@[Revision '#]]&""A""),([Submittal Date])),"""")"
            ActiveCell(i, 8) = Date     'H - Response Date                                               ' Response Date - prevents autofill from table
            If i < SIC Then
                Worksheets("LOG").ListObjects("Trans").ListRows.ADD                                      ' Adds a new row to the table
            End If
    Next xFile
    i = 0 ' resets i back to 0
Application.ScreenUpdating = True
GameOver:
End Sub
  
Sub TransmittalsOut()
  
    Dim xFiDialog As FileDialog
    Dim i, r, DeleteRows, SIC As Integer
    Dim REV, Tran, xPath, countfile, ypath As String
  
ActiveSheet.Shapes("Arrow-OUT").Visible = False
ActiveSheet.Shapes("Arrow-IN").Visible = False
ActiveSheet.Shapes("Cross1").Visible = True
      
  
On Error GoTo GameOver
Application.ScreenUpdating = False
  
    Set t3 = Worksheets("Transmittal").ListObjects("Trans3")
    Worksheets("LOG").Activate
  
        REV = InputBox(Prompt:="Enter Rev #", Title:="Rev #", Default:="0")
            If REV = vbNullString Then Exit Sub
          
        code = InputBox(Prompt:="Enter Transmittal Code.", Title:="Transmittal Code", Default:="C")
            If code = vbNullString Then Exit Sub
          
        DeleteRows = MsgBox("Adding to the Transmittal?", vbQuestion + vbYesNo)
          
        toJob = Worksheets("LOG").Range("B1").Value                 ' Gets Job Number
        ProjectNum = Worksheets("LOG").Range("D1").Value            ' Gets Project Number
        Notes = Worksheets("LOG").Range("D3").Value                 ' Gets Project Name
        toAddress = Worksheets("LOG").Range("F2").Value             ' Gets the address of E-mail, FTP, Web Portal, etc...
        toAttn = Worksheets("LOG").Range("F1").Value                ' Gets AttnTo
  
    Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
      
        With xFiDialog
            .InitialFileName = ThisWorkbook.Path
            .AllowMultiSelect = False
                If .Show = -1 Then xPath = xFiDialog.SelectedItems(1)
        End With
      
    Set xFiDialog = Nothing
      
        If xPath = "" Then Exit Sub
            Set xFSO = CreateObject("Scripting.FileSystemObject")
            Set xFolder = xFSO.GetFolder(xPath)
       
' Count the number of files
        ypath = xPath & "\*.*"
        countfile = Dir(ypath)
        Do While countfile <> ""
            SIC = SIC + 1
            countfile = Dir()
        Loop

MsgBox "File Count = " & SIC, vbOKOnly


        Range("A5").End(xlDown).Select
            If ActiveCell().Value <> "" Then
                    Worksheets("LOG").ListObjects("Trans").ListRows.ADD               ' Adds a new row to the table
                    ActiveCell().Offset(1).Select
                Else
                    ActiveCell.Offset(-1).Select
            End If
      
    For Each xFile In xFolder.Files
            i = i + 1
            ActiveSheet.Hyperlinks.ADD ActiveCell(i, 1), xFolder.Path, TextToDisplay:=xFolder.Name 'A - Transmittal # -- ' Hyperlink to folder, uses folder name as display text -options: xFile.Path, xFile.Name
                        'trimmer xFolder.Path
                        'ActiveCell(i, 3) = myFolderName 'xFolder.Path ' Folder Path (would like to shorten to \folder\folder\
            ActiveCell(i, 3) = xFile.Name  'C - File Name                                              ' returns filename and extension -- xFile.BaseName - returns just the filename
            ActiveCell(i, 4) = UCase(code) 'D - Transmittal Code                                            ' Transmittal Code
            ActiveCell(i, 5) = REV         'E - Revision #                                                  ' Document Rev #
            ActiveCell(i, 6).Formula = "=IF([@[Transmittal Code]]="""","""",LOOKUP(2,1/([File Name]=[@[File Name]]),([Transmittal Code])))" 'F - Status
            ActiveCell(i, 7) = Date        'G - Submittal Date                                              ' Current date
            'ActiveCell(i, 8) = ""          'H - Document Type                                               ' Document Type - prevents autofill from table
            If i < SIC Then
                Worksheets("LOG").ListObjects("Trans").ListRows.ADD                                             ' Adds a new row to the table
            End If
    Next xFile
        i = 0 ' resets i back to 0
Worksheets("Transmittal").PageSetup.CenterHeader = "&C&B" & toJob & "- Transmittal - " & xFolder.Name & vbLf & ProjectNum & vbLf & Notes


  
        Worksheets("Transmittal").Activate
        
            If DeleteRows = vbNo Then
                With t3
                    If .ListRows.Count >= 1 Then .DataBodyRange.Delete
                End With
                Range("B9").Select
                Else
                Range("B9").End(xlDown).Select
                    If Left(Trim(ActiveCell().Formula), 1) = "=" Then ActiveCell.Offset(-1).Select Else
                    If ActiveCell().Value <> "" Then
                        Worksheets("Transmittal").ListObjects("Trans3").ListRows.ADD           ' Adds a new row to the table
                        ActiveCell.Offset(1).Select
                    End If
            End If
              
        For Each xFile In xFolder.Files
                i = i + 1
                ActiveCell(i, 1) = xFile.Name                                                   ' Returns filename
                ActiveCell(i, 2) = REV                                                              ' Rev #
                'ActiveCell(i, 3) = -Currently Blank-                                               ' Blank
                ActiveCell(i, 4) = UCase(code)                                                      ' Transmittal Code
                    If UCase(code) = "C" Then
                            ActiveCell(i, 5) = "Shipment " & xFolder.Name & " Spool QA Data Package" ' Comments   xsubfolder.name
                        Else
                            ActiveCell(i, 5) = ""
                    End If
            If i < SIC Then
                Worksheets("Transmittal").ListObjects("Trans3").ListRows.ADD                     ' Adds New Row
            End If
         Next xFile
      
        Cells.Select
        Cells.EntireColumn.AutoFit
        Cells.EntireRow.AutoFit
        Range("B7").Select
     
    Worksheets("LOG").Activate
        Cells.Select
        Cells.EntireColumn.AutoFit
        Cells.EntireRow.AutoFit
        Range("A5").Select
    If Worksheets("Log").CheckBox1.Value = True Then
        ActiveWorkbook.FollowHyperlink Range("b4").Value
    End If
        SIC = 0
      
Application.ScreenUpdating = True
GameOver:
End Sub


Private Sub savefile()
   Dim SavePrompt As Integer
  
    SavePrompt = MsgBox("Save as PDF?", vbQuestion + vbYesNo)
        If SavePrompt = vbYes Then
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF
        Else
            Exit Sub
        End If
End Sub

Private Sub trimmer(FolderPath)
    Dim U As Variant

    On Error GoTo GameOver

'        x = xFolder.Path
        For U = Len(FolderPath) To 1 Step -1
            If Mid(FolderPath, U, 4) = "QCS)" Then GoTo SkipOut
            If Mid(FolderPath, U, 4) = "Q-QA" Then GoTo NextSkipOut
        Next U
SkipOut:
    myFolderName = Right(FolderPath, Len(FolderPath) - U - 20)
NextSkipOut:
    myFolderName = Right(FolderPath, Len(FolderPath) - U - 17)
  

GameOver:
End Sub

Sub SendEmail()
    Dim OutApp, OutMail As Object
    Dim AddressTo, PM, CcTo, Job, Client, Project, ProjectNumber, Greeting As String
  
  
If Time() < TimeValue("11:59:59 AM") Then Greeting = "Good morning,"
If Time() > TimeValue("12:00:00 PM") Then Greeting = "Good afternoon,"
If Time() > TimeValue("05:00:00 PM") Then Greeting = "Good evening,"
 
        AddressTo = Worksheets("LOG").Range("F2").Value     ' Contact Emails
        CcTo = Worksheets("LOG").Range("F3").Value          ' Contact Cc Emails
        PM = Worksheets("LOG").Range("B2").Value            ' Project Manager
        Job = Worksheets("LOG").Range("B1").Value           ' Project Name
        Client = Worksheets("LOG").Range("D2").Value        ' Client Name
        Project = Worksheets("LOG").Range("D3").Value       ' Project Name
        ProjectNumber = Worksheets("LOG").Range("D1").Value ' Project Number
      
  
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = AddressTo
            .Cc = CcTo & ";" & PM & ";" & "Dean Renard"
            .Subject = Job & "-" & xFolder.Name & " " & Client & " " & ProjectNumber & " " & Project & "-{DESCRIPTION}"
            .HTMLBody = Greeting
            '.Attachments.Add 'File to add
            .Display
        End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Thank you!!!
 
Last edited by a moderator:

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA code to create a hyperlink from files in a folder and assign to a cell with a similar name
2
Replies
18
Views
5K
Domenic
D
R
  • Solved
VBA Queries refresh and Save data as TXT
Replies
2
Views
289
Artik
Artik
melodramatic
  • Question Question
VBA - Sort Table in Alternate Workbook
Replies
1
Views
474
melodramatic
melodramatic
M
  • Question Question
[VBA]Copy data from specify cell and input value to another sheet with time stamp
Replies
2
Views
444
maiwarits
M
J
  • Question Question
VBA Script to Update Files in a folder, updating Links
Replies
1
Views
553
Micron
M

Forum statistics

Threads
1,224,821
Messages
6,181,163
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top