VBA修改代码。 列标题更改为不同的工作簿

我希望你能帮上忙。 我有一些下面的代码工作正常。 它所做的是打开一个对话框，允许用户select一个excel文件，一旦这个文件被选中。

代码通过列标题查找文本“国家代码”，然后削减此列将其放入列F中，然后将列F分隔为基于国家的新工作表。

我面临的这个问题是，有时我想要剪切的列包含文本“ClientField10”或“ClientField1”

所以我想要macros做的是search“CountryCode”的列标题，如果这被发现罚款执行其余的代码。

如果找不到“CleintField10”search，那么如果find执行，并且如果既没有find“CountyCode”或“CleintField10”search“CleintField1”，则执行其余的代码

我的代码如下总是非常感谢任何帮助。

Sub Open_Workbook_Dialog() Dim my_FileName As Variant Dim my_Workbook As Workbook MsgBox "Pick your TOV file" '<--| txt box for prompt to pick a file my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection If my_FileName <> False Then Set my_Workbook = Workbooks.Open(Filename:=my_FileName) Call Sample(my_Workbook) '<--|Calls the Filter Code and executes Call Filter(my_Workbook) '<--|Calls the Filter Code and executes End If End Sub Public Sub Sample(my_Workbook As Workbook) Dim ws As Worksheet Dim aCell As Range, Rng As Range Dim col As Long, lRow As Long Dim colName As String '~~> Change this to the relevant sheet Set ws = my_Workbook.Sheets(1) With ws Set aCell = .Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _ MatchCase:=False, SearchFormat:=False) '~~> If Found If Not aCell Is Nothing Then '~~> Cut the entire column aCell.EntireColumn.Cut '~~> Insert the column here Columns("F:F").Insert Shift:=xlToRight Else MsgBox "Country Not Found" End If End With End Sub Public Sub Filter(my_Workbook As Workbook) Dim rCountry As Range, helpCol As Range With my_Workbook.Sheets(1) '<--| refer to data worksheet With .UsedRange Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in End With With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A" .Columns(6).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 6th column of the referenced range and store its unique values in "helper" column Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row) For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row) .AutoFilter 6, rCountry.Value2 '<--| filter data on country field (6th column) with current unique country name If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered... Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet ActiveSheet.Name = rCountry.Value2 '<--... rename it .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header End If Next End With .AutoFilterMode = False '<--| remove autofilter and show all rows back End With helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included) End Sub 

Answer 1

因为之前我没有去testing我的代码，所以我犯了一个使用“If”而不是“ElseIf”语句的愚蠢错误。 我testing了下面的代码，现在它工作。

 Sub test() Dim acell As Range Dim ws As Worksheet Set ws = ActiveWorkbook.Sheets(1) 'define ws Set acell = ws.Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _ MatchCase:=False, SearchFormat:=False) 'define acell as location of "countrycode" If Not acell Is Nothing Then 'if address is found do the cut & insert of that column acell.EntireColumn.Cut Columns("F:F").Insert Shift:=xlToRight ElseIf acell Is Nothing Then 'if address is not found redefine acell to look for "clientfield10" Set acell = ws.Range("A1:BB50").Find(What:="ClientField10", LookIn:=xlValues, LookAt:=xlWhole, _ MatchCase:=False, SearchFormat:=False) If Not acell Is Nothing Then 'if address is found do the cut & insert acell.EntireColumn.Cut Columns("F:F").Insert Shift:=xlToRight ElseIf acell Is Nothing Then 'If not found redefine acell again to look for "ClientField1" Set acell = ws.Range("A1:BB50").Find(What:="ClientField1", LookIn:=xlValues, LookAt:=xlWhole, _ MatchCase:=False, SearchFormat:=False) If Not acell Is Nothing Then 'If found do cut and insert acell.EntireColumn.Cut Columns("F:F").Insert Shift:=xlToRight Else: MsgBox "Country Not Found" 'If none can be found display msgbox End If End If End If 'close all the If loops End Sub 

我将删除我的旧答案，使这个线程更容易理解