excel按字符串过滤列

Question

我有一个有1800行和30列的excel表。我只需要大约7栏，名称永不改变（例如：“名称”“姓”“标题”等）。

有没有可能设置一个过滤器来做到这一点？我只发现了一个有2条标准的过滤器，而我需要7个。

有没有可用的插件/脚本，还是我需要自己写一个？ （从来没有在Excel中编程）

Google结果与我的问题不同。 （也许我忽略了的东西）

/编辑：

的更多信息： 文件有这样的格式例如： “姓名”， “标题”， “X”， “Y”， “important1”，” important2" ， “X”

和下一个： “姓名”， “标题”， “important1”， “X”， “important2”， “X”， “Y”

我已经改变托尼的代码如下：

Option Explicit 
Sub DeleteOtherColumnsBeta() 

Dim ColCrnt As Long 
Dim ColsToKeepNum() As Long 
Dim ColsToKeepName() As Variant 
Dim InxKeep As Long 

' Load names of columns that are to remain visible. The code below assumes 
' these names are in ascending order by column number. These names must be 
' exactly the same as in the worksheet: same case, same spaces, etc. 
ColsToKeepName = Array(
"Teilbereich", "Anrede", "Titel", "Vorname", "Nachname", "Lehrveranstaltung", _ 
"Lehrveranstaltungsart", "Periode", "Bogen") 

ReDim ColsToKeepNum(LBound(ColsToKeepName) To UBound(ColsToKeepName)) 


With Sheets("Sheet1")  ' Replace "Sheet3" with the name of your sheet 

' Locate columns to remain visible 
ColCrnt = 1 
For InxKeep = LBound(ColsToKeepName) To UBound(ColsToKeepName) 
    Do While ColsToKeepName(InxKeep) <> .Cells(1, ColCrnt).Value 
    ColCrnt = ColCrnt + 1 
    If ColCrnt > Columns.Count Then 
     Call MsgBox("Column headed """ & ColsToKeepName(InxKeep) & _ 
               """ not found", vbOKOnly) 
     Exit Sub 
    End If 
    Loop 
    ColsToKeepNum(InxKeep) = ColCrnt 
    Call MsgBox("ColsToKeepNum(InxKeep)""" & ColsToKeepNum(InxKeep), vbOKOnly) 
Next 

' ColsToKeepNum() now contains a list of column numbers which are 
' the columns to remain visible. All others are to be hidden. 

ColCrnt = Columns.Count ' Last column processed 
' Hide columns before first named column and between named columns 
For InxKeep = UBound(ColsToKeepName) To LBound(ColsToKeepName) 
    If ColCrnt - 1 = ColsToKeepNum(InxKeep) Then 
    ' There is no gap between last processed column and this column 
    ' containing columns to be hidden 
    Else 
    .Range(.Cells(1, ColCrnt - 1), _ 
      .Cells(1, ColsToKeepNum(InxKeep) + 1)).EntireColumn.Delete 
    End If 
    ColCrnt = ColsToKeepNum(InxKeep)  ' Last processed column 
Next 
'Hide columns after last named column 
.Range(.Cells(1, ColCrnt - 1), _ 
      .Cells(1, Columns.Count)).EntireColumn.Delete 

End With 

End Sub 

Answer 1

过滤器是用户隐藏行或列的简单方法。我相信下面的代码在你的情况下提供了一个合适的选择。

ColsToKeepName = Array("Name", "Addr", "Title", "Given", "Phone", _ 
         "Home", "Mobile") 

与要保持可见的列的名称：

在更换名称。您可以增加或减少名称的数量。名称必须按列号升序排列，并且必须与工作表中的列标题完全匹配。

宏HideOtherColumns将隐藏所有其他列

宏RestoreColumns将恢复隐藏的列。

我认为代码非常简单，所以注释只解释代码的用途。如果你不明白我在做什么，请回答问题。

希望这会有所帮助。

Option Explicit 
Sub HideOtherColumns() 

    Dim ColCrnt As Long 
    Dim ColsToKeepNum() As Long 
    Dim ColsToKeepName() As Variant 
    Dim InxKeep As Long 

    ' Load names of columns that are to remain visible. The code below assumes 
    ' these names are in ascending order by column number. These names must be 
    ' exactly the same as in the worksheet: same case, same spaces, etc. 
    ColsToKeepName = Array("Name", "Addr", "Title", "Given", "Phone", _ 
         "Home", "Mobile") 

    ReDim ColsToKeepNum(LBound(ColsToKeepName) To UBound(ColsToKeepName)) 

    With Sheets("Sheet3")  ' Replace "Sheet3" with the name of your sheet 

    ' Locate columns to remain visible 
    ColCrnt = 1 
    For InxKeep = LBound(ColsToKeepName) To UBound(ColsToKeepName) 
     Do While ColsToKeepName(InxKeep) <> .Cells(1, ColCrnt).Value 
     ColCrnt = ColCrnt + 1 
     If ColCrnt > Columns.Count Then 
      Call MsgBox("Column headed """ & ColsToKeepName(InxKeep) & _ 
                """ not found", vbOKOnly) 
      Exit Sub 
     End If 
     Loop 
     ColsToKeepNum(InxKeep) = ColCrnt 
    Next 

    ' ColsToKeepNum() now contains a list of column numbers which are 
    ' the columns to remain visible. All others are to be hidden. 

    ColCrnt = 0  ' Last column processed 
    ' Hide columns before first named column and between named columns 
    For InxKeep = LBound(ColsToKeepName) To UBound(ColsToKeepName) 
     If ColCrnt + 1 = ColsToKeepNum(InxKeep) Then 
     ' There is no gap between last processed column and this column 
     ' containing columns to be hidden 
     Else 
     .Range(.Cells(1, ColCrnt + 1), _ 
       .Cells(1, ColsToKeepNum(InxKeep) - 1)).EntireColumn.Hidden = True 
     End If 
     ColCrnt = ColsToKeepNum(InxKeep)  ' Last processed column 
    Next 
    'Hide columns after last named column 
    .Range(.Cells(1, ColCrnt + 1), _ 
       .Cells(1, Columns.Count)).EntireColumn.Hidden = True 

    End With 

End Sub 
Sub RestoreColumns() 

    With Sheets("Sheet3") 
    .Range(.Cells(1, 1), .Cells(1, Columns.Count)).EntireColumn.Hidden = False 
    End With 

End Sub 

新程序来删除在同一文件夹中所有的XLS文件列作为主簿

记住：一旦一列被删除，无法恢复。所以确保你有一个原始文件的副本。但是，这里的代码不会删除任何内容。相反，它会输出应该删除的内容的描述。我已经测试过这段代码，但是我们需要在删除列之前用工作簿检查它。

我打算调用包含宏Master.xls的工作簿。此代码假定所有要从中删除列的工作簿与Master.xls位于同一文件夹中。此代码假定Master.xls包含名为DelCol的工作表。如果您不喜欢我的名字，请在代码中更改DelCol。

您将需要一个例程来查找文件夹中的所有Excel文件。我之前写过这个：

Sub GetFileNameList(ByVal PathCrnt As String, ByVal FileSpec As String, _ 
              ByRef FileNameList() As String) 

' This routine sets FileNameList to the names of files within folder 
' PathCrnt that match FileSpec. It uses function Dir$() to get the file names. 
' I can find no documentation that says Dir$() gets file names in alphabetic 
' order but I have not seen a different sequence in recent years 

    Dim AttCrnt As Long 
    Dim FileNameCrnt As String 
    Dim InxFNLCrnt As Long 

    ReDim FileNameList(1 To 100) 
    InxFNLCrnt = 0 

    ' Ensure path name ends in a "\" 
    If Right(PathCrnt, 1) <> "\" Then 
    PathCrnt = PathCrnt & "\" 
    End If 

    ' This Dir$ returns the name of the first file in 
    ' folder PathCrnt that matches FileSpec. 
    FileNameCrnt = Dir$(PathCrnt & FileSpec) 
    Do While FileNameCrnt <> "" 
    ' "Files" have attributes, for example: normal, to-be-archived, system, 
    ' hidden, directory and label. It is unlikely that any directory will 
    ' have an extension of XLS but it is not forbidden. More importantly, 
    ' if the files have more than one extension so you have to use "*.*" 
    ' instead of *.xls", Dir$ will return the names of directories. Labels 
    ' can only appear in route directories and I have not bothered to test 
    ' for them 
    AttCrnt = GetAttr(PathCrnt & FileNameCrnt) 
    If (AttCrnt And vbDirectory) <> 0 Then 
     ' This "file" is a directory. Ignore 
    Else 
     ' This "file" is a file 
     InxFNLCrnt = InxFNLCrnt + 1 
     If InxFNLCrnt > UBound(FileNameList) Then 
     ' There is a lot of system activity behind "Redim Preserve". I reduce 
     ' the number of Redim Preserves by adding new entries in chunks and 
     ' using InxFNLCrnt to identify the next free entry. 
     ReDim Preserve FileNameList(1 To 100 + UBound(FileNameList)) 
     End If 
     FileNameList(InxFNLCrnt) = FileNameCrnt 
    End If 
    ' This Dir$ returns the name of the next file that matches 
    ' the criteria specified in the initial call. 
    FileNameCrnt = Dir$ 
    Loop 

    ' Discard the unused entries 
    ReDim Preserve FileNameList(1 To InxFNLCrnt) 

End Sub 

尽管名称下面的宏不删除列。除删除列之外，它会做所有必要的事宏检查文件夹中的每个工作表或每个工作簿。如果工作表不包含所有必需的列，则宏会报告它。如果工作表包含所有必需的列，则会报告要删除哪些列。

在你的系统上测试这个宏，并检查它是否满足你的要求。届时我会测试删除代码。

Sub DeleteColumns() 

    Dim ColOtherCrnt As Long 
    Dim ColOtherEnd As Long 
    Dim ColOtherStart As Long 
    Dim ColOtherMax As Long 
    Dim ColsToDelete() As Long 
    Dim ColsToKeepFound() As Boolean 
    Dim ColsToKeepName() As Variant 
    Dim FileNameList() As String 
    Dim Found As Boolean 
    Dim InxCTDCrnt As Long 
    Dim InxCTDMax As Long 
    Dim InxCTK As Long 
    Dim InxFNLCrnt As Long 
    Dim InxWShtCrnt As Long 
    Dim Msg As String 
    Dim PathCrnt As String 
    Dim RowDelColNext As Long 
    Dim WBookMaster As Workbook 
    Dim WBookOther As Workbook 

    If Workbooks.Count > 1 Then 
    ' It is easy to get into a muddle if there are multiple workbooks 
    ' open at the start of a macro like this. Avoid the problem. 
    Call MsgBox("Please close all other workbooks", vbOKOnly) 
    Exit Sub 
    End If 

    Set WBookMaster = ActiveWorkbook 

    ' Load names of columns that are NOT to be deleted These names must be 
    ' actually the same as in the worksheet: same case, same spaces, etc. 
    ' ##### Change this list as required. ##### 
    ColsToKeepName = Array("Name", "Addr", "Title", "Given", "Phone", "Home", "Mobile") 

    ' Get the name of the folder containing this workbook. 
    PathCrnt = ActiveWorkbook.Path & "\" 

    ' Delete existing contents of worksheet DelCol and prepare for use 
    With Sheets("DelCol") 
    .Cells.EntireRow.Delete 
    .Cells(1, 1).Value = "Workbook" 
    .Cells(1, 2).Value = "Worksheet" 
    .Cells(1, 3).Value = "Comment" 
    .Range(.Cells(1, 1), .Cells(1, 3)).Font.Bold = True 
    End With 
    RowDelColNext = 2 

    ' If you are using a later version of Excel, you will 
    ' need to change the file specification. 
    Call GetFileNameList(PathCrnt, "*.xls", FileNameList) 

    For InxFNLCrnt = 1 To UBound(FileNameList) 
    If FileNameList(InxFNLCrnt) = WBookMaster.Name Then 
     ' This workbook is the master 
     Set WBookOther = WBookMaster 
    Else 
     Set WBookOther = Workbooks.Open(PathCrnt & FileNameList(InxFNLCrnt)) 
    End If 
    With WBookOther 
     ' Store name of workbook 
     WBookMaster.Sheets("DelCol").Cells(RowDelColNext, 1).Value = .Name 
     RowDelColNext = RowDelColNext + 1 

     ' Examine every worksheet in workbook 
     For InxWShtCrnt = 1 To .Worksheets.Count 
     With .Worksheets(InxWShtCrnt) 
      ' Store name of worksheet 
      WBookMaster.Sheets("DelCol").Cells(RowDelColNext, 2).Value = .Name 
      RowDelColNext = RowDelColNext + 1 

      ' #### Add code to ignore any workbooks 
      ' #### you do not want examined 

      ' .Range(Y).SpecialCells(X) finds a cell or cells of type X 
      ' within range Y. ".Cells" means the entire worksheet. 
      ' "xlCellTypeLastCell" means the last used cell or cells. 
      ' I have extracted the column number. If ColOtherMax = 50 
      ' then I know I need not consider columns 51, 52, etc. 
      ColOtherMax = .Cells.SpecialCells(xlCellTypeLastCell).Column 

      ' Size array for one entry per name. Initialise to False 
      ReDim ColsToKeepFound(LBound(ColsToKeepName) To _ 
           UBound(ColsToKeepName)) 

      ' Size array for the maximum possible number of columns. 
      ReDim ColsToDelete(1 To ColOtherMax) 
      InxCTDMax = 0  ' Array currently empty 

      ' Example row 1 of every column 
      For ColOtherCrnt = ColOtherMax To 1 Step -1 

      ' Match column header against names to keep 
      Found = False 
      For InxCTK = LBound(ColsToKeepName) To UBound(ColsToKeepName) 
       If .Cells(1, ColOtherCrnt).Value = ColsToKeepName(InxCTK) Then 
       Found = True 
       Exit For 
       End If 
      Next 

      ' Record findings 
      If Found Then 
       ' This column is to be kept 
       ColsToKeepFound(InxCTK) = True 
      Else 
       ' This column is to be deleted 
       InxCTDMax = InxCTDMax + 1 
       ColsToDelete(InxCTDMax) = ColOtherCrnt 
      End If 
      Next 

      ' Check all columns to be kept have been found 
      Found = True 
      For InxCTK = LBound(ColsToKeepName) To UBound(ColsToKeepName) 
      If Not ColsToKeepFound(InxCTK) Then 
       Found = False 
       Exit For 
      End If 
      Next 

      If Found Then 
      ' All required columns have been found. Prepare to 
      ' delete remaining columns 
      Msg = "Columns to be deleted:" 
      ColOtherStart = ColsToDelete(1) 
      ColOtherEnd = ColsToDelete(1) 
      For InxCTDCrnt = 2 To InxCTDMax 
       If ColsToDelete(InxCTDCrnt) + 1 = ColOtherStart Then 
       ' Range continues 
       ColOtherStart = ColsToDelete(InxCTDCrnt) 
       Else 
       ' End of last range. Start of new. 
       If ColOtherStart = ColOtherEnd Then 
        Msg = Msg & " " & ColOtherStart & " " 
       Else 
        Msg = Msg & " " & ColOtherStart & " to " & ColOtherEnd & " " 
       End If 
       ColOtherStart = ColsToDelete(InxCTDCrnt) 
       ColOtherEnd = ColsToDelete(InxCTDCrnt) 
       End If 
      Next 
      If ColOtherStart = ColOtherEnd Then 
       Msg = Msg & " " & ColOtherStart & " " 
      Else 
       Msg = Msg & " " & ColOtherStart & " to " & ColOtherEnd & " " 
      End If 
      WBookMaster.Sheets("DelCol").Cells(RowDelColNext, 2).Value = Msg 
      RowDelColNext = RowDelColNext + 1 
      Else 
      ' Not all required columns found. 
      Msg = "The following required columns were not found:" 
      For InxCTK = LBound(ColsToKeepName) To UBound(ColsToKeepName) 
       If Not ColsToKeepFound(InxCTK) Then 
        Msg = Msg & " " & ColsToKeepName(InxCTK) 
       End If 
      Next 
      WBookMaster.Sheets("DelCol").Cells(RowDelColNext, 3).Value = Msg 
      RowDelColNext = RowDelColNext + 1 
      End If 
     End With 
     Next 
     If FileNameList(InxFNLCrnt) = WBookMaster.Name Then 
     ' This workbook is the master 
     Else 
     .Close SaveChanges:=False ' Close the workbook without saving it 
     End If 
     Set WBookOther = Nothing ' Clear reference to workbook 
    End With 
    Next 

End Sub 

上第二个程序

评论不要担心使用Java。我曾经很熟练掌握C语言，并且能够理解大多数C语言的语法。

新代码不需要列处于任何特定序列中，因为您说所有工作簿中的序列都不相同。

新代码和旧代码都需要完全匹配。有很多技术可以进行局部匹配，但我不知道哪个比较合适。例如：

• if Lcase(X) = Lcase(Y) then意味着“名称”，“名称”和“名称”全部匹配。
• if Replace(X," ","") = Replace(Y," ","") then意味着“first name”和“firstname”匹配。
• Like是执行通配符匹配的运算符。
• 您已经发现Instr这是另一种可能性，虽然我怀疑Like会给你更多的灵活性。不过，我对InStr和Like有点不舒服。他们将允许您将“addr”与“address”和“home addr”相匹配，而“name”则与“enamel”匹配。 “珐琅”一词似乎不太可能出现在您的任何标题行中，但我希望您能看到我的担忧。
• 如果您使用的Excel版本比我高，那么您可以通过其所有的灵活性访问Regex。
• 您可以嵌套呼叫，例如：Lcase(Replace(X," ",""))。

新代码的目的是在不删除任何东西的情况下测试例程的效果。如果您要查找部分匹配，我建议您将输出更改为工作表“ColDel”以包含匹配名称的列表。

您不必一次就可以处理每个工作簿。你可以处理简单的工作簿并将它们移动到其他地方，让你专注于困难的工作簿。