Question

我有一个包含.txt文件的文件夹（它们包含PHI，因此我无法上传.txt文件，或者没有PHI的示例，甚至包含它的任何图像）。我需要一个excel宏，它允许用户选择包含该文件的文件夹，然后将.txt文件数据插入到新的excel工作簿中，适当地格式化行和列，最后将文件保存到同一文件夹发现了来源。到目前为止，除了行和列的格式化之外，我已经完成了所有工作。截至目前，.txt数据被插入到新的工作簿中。工作表，但我似乎无法弄清楚如何摆脱我不需要的行，或如何正确地格式化列。

同样，我无法上传.txt文件（或任何内容），因为我工作的医疗保健组织会阻止它 - 即使我已删除所有PHI。

以下是我目前创建的宏：

    Private Sub CommandButton2_Click()

    On Error GoTo err

    'Allow the user to choose the FOLDER where the TEXT file(s) are located
    'The resulting EXCEL file will be saved in the same location
        Dim FldrPath As String
        Dim fldr As FileDialog
        Dim fldrChosen As Integer

        Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
        With fldr
            .Title = "Select a Folder containing the Text File(s)"
            .AllowMultiSelect = False
            .InitialFileName = "\\FILELOCATION"
            fldrChosen = .Show

            If fldrChosen <> -1 Then
                MsgBox "You Chose to Cancel"
            Else
                FldrPath = .SelectedItems(1)
            End If

        End With


    If FldrPath <> "" Then

        'Make a new workbook
            Dim newWorkbook As Workbook
            Set newWorkbook = Workbooks.Add

        'Make worksheet1 of new workbook active
            newWorkbook.Worksheets(1).Activate


        'Completed files are saved in the chosen source file folder
               Dim CurrentFile As String: CurrentFile = Dir(FldrPath & "\" & "*.txt")
               Dim strLine() As String
               Dim LineIndex As Long

               Application.ScreenUpdating = False
               Application.DisplayAlerts = False
               While CurrentFile <> vbNullString
                   'How many rows to place in Excel ABOVE the data we are inserting
                   LineIndex = 0
                   Close #1
                   Open FldrPath & "\" & CurrentFile For Input As #1
                   While Not EOF(1)
                        'Adds number of rows below the inserted row of data
                        LineIndex = LineIndex + 1

                        ReDim Preserve strLine(1 To LineIndex)
                        Line Input #1, strLine(LineIndex)

                   Wend
                   Close #1

                   With ActiveSheet.Range("A1").Resize(LineIndex, 1)
                       .Value = WorksheetFunction.Transpose(strLine)
                       .TextToColumns Other:=True, OtherChar:="|"
                   End With

                   ActiveSheet.UsedRange.EntireColumn.AutoFit
                   ActiveSheet.Name = Replace(CurrentFile, ".txt", "")
                    ActiveWorkbook.SaveAs FldrPath & "\" & Replace(CurrentFile, ".txt", ".xls"), xlNormal
                   ActiveWorkbook.Close

                   CurrentFile = Dir
               Wend
               Application.DisplayAlerts = True
               Application.ScreenUpdating = True
    End If

    Done:
        Exit Sub

    err:
        MsgBox "The following ERROR Occurred:" & vbNewLine & err.Description
        ActiveWorkbook.Close


    End Sub

有关如何删除整行的信息的任何想法？我如何适当地格式化列？因此，我没有从.txt文件中获取3列，而是在生成的excel文件中将所有列压缩为1列？

由于

Answer 1

我建议你不要重新发明轮子。 Microsoft提供了一个出色的附加组件来完成此任务Power Query。

它允许您加载文件夹中的每个文件并以批量处理它。 Here you have a brief introduction of what can do for you.

将.txt文件转换为.xlsx＆amp;删除不需要的行＆amp;正确格式化列

1 个答案: