Update VBA Code to Include Parameter for Delimiter, File Location and Overwrite Sheets when Re-Run

JFK_Lives · Aug 24th 2022

Excel Version = 365

OS = Windows

Good Day,

I'm sure this question has been posted a thousand times and there are tons on this on Google, but I just can't find the right piece of code I need.

I don't know VBA at All so Apologies if I ask a lot of dumb obvious questions.

Short Description of what is needed:

I have Software that writes out Text Files to a Specific Folder on the Local HDD. These Text Files all have Unique Names and use " | " as a Delimiter.

Each Day when the User clicks the Button, These Text Files must be Imported into the Same Workbook the Code is Run from, Each Text File on it's Own Worksheet.

If the Button is Pressed Again, the Text Files are Imported Again and must Overwrite the Worksheet with the Same Name, not Create a New Worksheet, Thus Asset Text File will each time overwrite the Worksheet Named Asset etc.

I found this Code that does the Importing and Creates the Worksheets per File Name:

Code

Sub Test()
'UpdatebyExtendoffice6/7/2016
Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long


Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)


End If


If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Then
MsgBox "No files found", vbInformation, "Kutools for Excel"


Exit Sub
End If


Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()


Loop


Set xToBook = ThisWorkbook
If xFiles.Count > 0 Then
For I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)


On Error Resume Next


ActiveSheet.Name = xWb.Name


On Error GoTo 0


xWb.Close False


Next


End If
End Sub

Display More

But I need the Following Add:

1. Option the Specify which Delimiter to Use.

2. Option to Specify the Folder Location so that the User doesn't have to Choose it each time, the code must automatically import the files from the Folder Location Supplied.

3. When the Code is Run Again, just Overwrite the Worksheet with the same name, not create a New Worksheet.

Any Help or Suggestions will be Greatly Appreciated.

Thanks

dangelor · Aug 26th 2022

Possibly...

Code

Sub test()
    Dim vFiles As Variant, v As Variant
    Dim wb As Workbook, ws As Worksheet, sTabName As String
    Const sPATH As String = "C:\temp"             'change as needed

    vFiles = fnGetFiles(sPATH, "txt")
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    With ThisWorkbook
        For Each v In vFiles
            Set wb = Workbooks.Open(v, ReadOnly:=True)
            sTabName = wb.Worksheets(1).Name
            ThisWorkbook.Activate
            If Evaluate("ISREF('" & sTabName & "'!A1)") Then .Worksheets(sTabName).Delete
            wb.Worksheets(1).Copy after:=.Sheets(.Sheets.Count)
            wb.Close
        Next v
    End With
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub
Private Function fnGetFiles(sPATH As String, Optional EXT As String) As Variant
    Dim sFileName As String
    With CreateObject("Scripting.Dictionary")
        If EXT = vbNullString Then
            sFileName = Dir(sPATH, vbNormal)
        Else
            sFileName = Dir(sPATH & "\*." & EXT & "*", vbNormal)
        End If
        Do While Not sFileName = vbNullString
            .Item(sPATH & "\" & sFileName) = Empty
            sFileName = Dir
        Loop
        fnGetFiles = .keys
    End With
End Function

Display More

Update VBA Code to Include Parameter for Delimiter, File Location and Overwrite Sheets when Re-Run

Participate now!

Share

Tags