Question

我有一个包含200个文本文件的文件夹，我想从每个文件中删除两列，并使用与以前相同的名称和格式保存。手动我可以通过打开excel中的每个文件然后删除列并保存回输出更改文件扩展名来完成此操作。任何人都可以帮助一些excel宏。感谢

Answer 1

Sub ConvertFileToCSV(sPath As String)
Dim wbToConvert As Workbook
Workbooks.OpenText Filename:= _
              sPath, Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
              xlSingleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
               , Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
              Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
              Array(9, 1)), TrailingMinusNumbers:=True
Set wbToConvert = ActiveWorkbook
With wbToConvert
    With .Sheets(1)
        .Columns("B:B").EntireColumn.Delete
        .Columns("C:C").EntireColumn.Delete
    End With

    .SaveAs Filename:=WorksheetFunction.Substitute(sPath, ".txt", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
    .Close savechanges:=False
End With

End Sub

这将允许您将文件的名称传递给函数，打开工作区，删除列B和C，然后将其另存为csv。从那里我们只需要调用它，我们可以用这样的例程来做它

Sub ConvertEach()
Dim fso As Object, _
    ShellApp As Object, _
    File As Object, _
    SubFolder As Object, _
    Directory As String, _
    Problem As Boolean
'Turn off screen flashing
Application.ScreenUpdating = False
'Create objects to get a listing of all files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
    Problem = False
    Set ShellApp = CreateObject("Shell.Application"). _
                   Browseforfolder(0, "Please choose a folder", 0, "c:\\")
    On Error Resume Next
    'Evaluate if directory is valid
    Directory = ShellApp.self.Path
    Set SubFolder = fso.GetFolder(Directory).Files
    If Err.Number <> 0 Then
        If MsgBox("You did not choose a valid directory!" & vbCrLf & _
                  "Would you like to try again?", vbYesNoCancel, _
                  "Directory Required") <> vbYes Then Exit Sub
        Problem = True
    End If
    On Error GoTo 0
Loop Until Problem = False
'Look through each file
For Each File In SubFolder
    If Not Excludes(Right(File.Path, 3)) = True Then
        If Right(LCase(File.Path), 3) = "txt" Then
            Call ConvertFileToCSV(LCase(File.Path))
        End If
    End If
Next
End Sub

Answer 2

下面的示例使用添加到Module.Module1类

的ActiveX按钮和代码

您需要为FileSystemObject添加引用.. Add Scripting Reference Required

在Module1类中（您可以运行此宏）..

    Sub Macro1()
    Dim sFldr As String
    Dim fso As Scripting.FileSystemObject
    Dim fsoFile As Scripting.File
    Dim fsoFldr As Scripting.Folder

    Set fso = New Scripting.FileSystemObject

    sFldr = "C:\Temp\stackoverflow\excel\"

    Set fsoFldr = fso.GetFolder(sFldr)

    For Each fsoFile In fsoFldr.Files

        Workbooks.Open Filename:=fsoFile.Path
        Columns("E:F").Select
        Selection.Delete Shift:=xlToLeft
        ActiveWorkbook.Save
        ActiveWindow.Close
    Next fsoFile

End Sub

添加了ActiveX按钮以在Sheet1上调用上面的宏..

Private Sub CommandButton1_Click()

    Call Module1.Macro1

End Sub

Excel宏从文件夹中的所有文件中删除特定列

2 个答案: