Фильтр - это простой способ скрыть строки или столбцы.Я полагаю, что приведенный ниже код предлагает подходящую альтернативу в вашей ситуации.
Замените имена в:
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рабочая книга
Помните: после удаления столбца его невозможно восстановить.Поэтому убедитесь, что у вас есть копия оригинальных файлов.Однако код здесь ничего не удаляет.Вместо этого он выводит описание того, что должно быть удалено.Я проверил этот код, но нам нужно проверить его с вашими рабочими книгами, прежде чем удалять столбцы.
Я собираюсь назвать рабочую книгу, содержащую макросы 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 будет означать, что "NAME", "name" и "Name" все совпадают. if Replace(X," ","") = Replace(Y," ","") then будет означать, что "name" и "firstname "matched. Like - оператор, выполняющий сопоставление с подстановочными знаками. - Вы обнаружили
Instr, что является еще одной возможностью, хотя я подозреваю, что Like даст вам больше гибкости.Однако мне немного неудобно с InStr и Like.Они позволят вам сопоставить «addr» с «address» и «home addr», а также «name» с «enamel».Кажется маловероятным, что слово «эмаль» появляется в любой из строк заголовка, но я надеюсь, что вы понимаете мою обеспокоенность. - Если вы используете более позднюю версию Excel, чем я, у вас есть доступ к Regex со всемиего гибкость.
- Вы можете вкладывать вызовы, например:
Lcase(Replace(X," ","")).
Цель нового кода - проверить влияние процедуры, не удаляя ничего.Если вы собираетесь искать частичные совпадения, я предлагаю вам изменить вывод на рабочий лист "ColDel", чтобы включить список совпадающих имен.
Вам не нужно обрабатывать каждую книгу в однойпроходить.Вы можете обращаться с простыми рабочими книгами и перемещать их в другое место, оставляя вам возможность сосредоточиться на сложных книгах.