连接三段代码 "Open Dialog Box" "Cut and Paste" 和 "Split Column Rename"
Joining three pieces of Code "Open Dialog Box" "Cut and Paste" and "Split Column Rename"
希望对你有所帮助。我有以下三段代码。这三者完全相互独立地工作。一切编译宏只是不会正确执行。
第一段代码 Sub Open_Workbook_Dialog() 打开一个对话框并允许用户 select 一个文件。
第二段代码 Public Sub Sample() 在列标题中搜索文本 'CountryCode'，然后剪切该列并将其粘贴到 F 列中。
第三段代码 Public Sub Filter() 获取 F 列并将其拆分为新的工作表，并根据国家/地区重命名工作表。
所以本质上，宏应该做的是打开一个对话框获取文件，找到国家/地区列所在的位置，将其剪切并粘贴到 F 列，然后将此列拆分为新工作表并重命名。
就像我说的，所有代码独立运行都很好，但是当我把它们放在一起时。对话框打开我 select 我的文件然后我得到 Msgbox "Country not Found" 即使国家代码列在 范围内我认为 Set aCell = .Range("A1:X50")国家/地区代码在 W 列中。
单击 MsgBox "Country not Found" 后，Public Sub Filter() 执行并拆分并重命名了错误的列。查找似乎没有发生，因此剪切和粘贴没有发生。
我附上了图片以便更好地理解。
未找到国家/地区
被错误的F分裂
代码如下
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
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
Workbooks.Open Filename:=my_FileName
Call Sample '<--|Calls the Filter Code and executes
Call Filter '<--|Calls the Filter Code and executes
End If
End Sub
Public Sub Sample()
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 = ThisWorkbook.Sheets("Sheet1")
With ws
Set aCell = .Range("A1:X50").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()
Dim rCountry As Range, helpCol As Range
With Worksheets("Sheet1") '<--| 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
问题是您不是在打开的工作簿中搜索 "CountryCode"，而是在工作簿中搜索 运行 您的代码。所以基本上你有一个工作簿，你可以在其中启动你的宏代码并打开另一个你想要使用的工作簿（通过使用你的对话框）。但是在您的 Public Sub Sample() 中，您的问题是：
Set ws = ThisWorkbook.Sheets("Sheet1")
问题是您正在引用工作簿，您的宏代码是使用 ThisWorkbook 在其中编写和执行的。因为您不知道 Public Sub Sample() 中的文件名。我已经编辑了您的代码以使其按应有的方式工作：
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("Sheet1")
With ws
Set aCell = .Range("A1:X50").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.Worksheets("Sheet1") '<--| 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
您可能还想将带有 .Sheets("Sheet1")（或 .Worksheets("Sheet1")）的行更改为 .Sheets(1)（或 .Worksheets(1)），这样您就不会依赖于命名在打开的工作簿中。
在设置 aCell 变量时，在您的行中包含具有 CountryCodes 的列（在本例中为 W 列）。
很有可能是引用问题。
用简单的英语来说，这意味着您没有传递新打开的工作簿的引用，因此您的另一个 Subs 不知道您在说哪个！
我已经举了一个例子来告诉你在哪里进行更改：
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
'~~> Changes here
Dim MainWbk As Workbook
Dim OpenedWbk As Workbook
'~~> Changes here
Set MainWbk = ThisWorkbook
MsgBox "Pick your TOV file"
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName <> False Then
'~~> Changes here
Set OpenedWbk = Workbooks.Open(Filename:=my_FileName)
'~~> Changes here
Call Sample(OpenedWbk, MainWbk)
''~~> Same changes to do here
'Call Filter
End If
End Sub
'~~> Changes here (arguments to pass the references of the workbooks)
Public Sub Sample(OpenedWbk As Workbook, MainWbk As Workbook)
Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
'~~> Changes here
Set ws = OpenedWbk.Sheets("Sheet1")
With ws
Set aCell = .Range("A1:X50").Find(What:="CountryCode", _
LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
aCell.EntireColumn.Cut
'~~> Changes here
MainWbk.Columns("F:F").Insert Shift:=xlToRight
Else
MsgBox "Country Not Found"
End If
End With
End Sub
希望对你有所帮助。我有以下三段代码。这三者完全相互独立地工作。一切编译宏只是不会正确执行。
第一段代码 Sub Open_Workbook_Dialog() 打开一个对话框并允许用户 select 一个文件。
第二段代码 Public Sub Sample() 在列标题中搜索文本 'CountryCode'，然后剪切该列并将其粘贴到 F 列中。
第三段代码 Public Sub Filter() 获取 F 列并将其拆分为新的工作表，并根据国家/地区重命名工作表。
所以本质上，宏应该做的是打开一个对话框获取文件，找到国家/地区列所在的位置，将其剪切并粘贴到 F 列，然后将此列拆分为新工作表并重命名。
就像我说的，所有代码独立运行都很好，但是当我把它们放在一起时。对话框打开我 select 我的文件然后我得到 Msgbox "Country not Found" 即使国家代码列在 范围内我认为 Set aCell = .Range("A1:X50")国家/地区代码在 W 列中。
单击 MsgBox "Country not Found" 后，Public Sub Filter() 执行并拆分并重命名了错误的列。查找似乎没有发生，因此剪切和粘贴没有发生。
我附上了图片以便更好地理解。
未找到国家/地区
被错误的F分裂
代码如下
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
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
Workbooks.Open Filename:=my_FileName
Call Sample '<--|Calls the Filter Code and executes
Call Filter '<--|Calls the Filter Code and executes
End If
End Sub
Public Sub Sample()
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 = ThisWorkbook.Sheets("Sheet1")
With ws
Set aCell = .Range("A1:X50").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()
Dim rCountry As Range, helpCol As Range
With Worksheets("Sheet1") '<--| 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
问题是您不是在打开的工作簿中搜索 "CountryCode"，而是在工作簿中搜索 运行 您的代码。所以基本上你有一个工作簿，你可以在其中启动你的宏代码并打开另一个你想要使用的工作簿（通过使用你的对话框）。但是在您的 Public Sub Sample() 中，您的问题是：
Set ws = ThisWorkbook.Sheets("Sheet1")
问题是您正在引用工作簿，您的宏代码是使用 ThisWorkbook 在其中编写和执行的。因为您不知道 Public Sub Sample() 中的文件名。我已经编辑了您的代码以使其按应有的方式工作：
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("Sheet1")
With ws
Set aCell = .Range("A1:X50").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.Worksheets("Sheet1") '<--| 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
您可能还想将带有 .Sheets("Sheet1")（或 .Worksheets("Sheet1")）的行更改为 .Sheets(1)（或 .Worksheets(1)），这样您就不会依赖于命名在打开的工作簿中。
在设置 aCell 变量时，在您的行中包含具有 CountryCodes 的列（在本例中为 W 列）。
很有可能是引用问题。
用简单的英语来说，这意味着您没有传递新打开的工作簿的引用，因此您的另一个 Subs 不知道您在说哪个！
我已经举了一个例子来告诉你在哪里进行更改：
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
'~~> Changes here
Dim MainWbk As Workbook
Dim OpenedWbk As Workbook
'~~> Changes here
Set MainWbk = ThisWorkbook
MsgBox "Pick your TOV file"
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName <> False Then
'~~> Changes here
Set OpenedWbk = Workbooks.Open(Filename:=my_FileName)
'~~> Changes here
Call Sample(OpenedWbk, MainWbk)
''~~> Same changes to do here
'Call Filter
End If
End Sub
'~~> Changes here (arguments to pass the references of the workbooks)
Public Sub Sample(OpenedWbk As Workbook, MainWbk As Workbook)
Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
'~~> Changes here
Set ws = OpenedWbk.Sheets("Sheet1")
With ws
Set aCell = .Range("A1:X50").Find(What:="CountryCode", _
LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
aCell.EntireColumn.Cut
'~~> Changes here
MainWbk.Columns("F:F").Insert Shift:=xlToRight
Else
MsgBox "Country Not Found"
End If
End With
End Sub