无法访问双范围
Trouble accessing dual ranges
我在网上找到了以下大部分代码，它们对我来说非常有用。我添加的部分是创建第二个范围 rngUniques2 以及使用该范围进行一些字符串操作。我遇到的问题是，当我尝试访问该范围时，除了第一次外，它没有提取正确的值。我在想我用错了柜台，但我没能把它改正。我知道范围中有正确的值，因为我为每个单元格调试打印。
Sub Extract_All_Data()
'this macro assumes that your first row of data is a header row.
'will copy all filtered rows from one worksheet, to another blank workbook
'each unique filtered value will be copied to it's own sheet
'Variables used by the macro
Dim wbOrig, wbDest As Workbook
Dim rngFilter As Range, rngUniques, rngUniques2 As Range
Dim cell As Range, counter As Integer
Dim xValue, OutValue As String
' Prompt user to choose file and open it
MsgBox "Please select the file that will be split."
strFileToOpen = Application.GetOpenFilename(Title:="Please select the file that will be split.", FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen = "False" Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wbOrig = Workbooks.Open(Filename:=strFileToOpen)
End If
Sheets("HTPN").Activate
' Set the filter range (from A1 to the last used cell in column A)
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
' Filter column A to show only one of each item (uniques) in column A
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
' Set a variable to the Unique values (one for ClientID and one for Client Name)
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
Set rngUniques2 = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
' Clear the filter
ActiveSheet.ShowAllData
End With
' Create a new workbook with a sheet for each unique value
Application.SheetsInNewWorkbook = rngUniques.Count
Set wbDest = Workbooks.Add
Application.SheetsInNewWorkbook = 3
' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
For Each cell In rngUniques
counter = counter + 1
'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
' Copy and paste the filtered data to it's unique sheet
rngFilter.Resize(, 30).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
' Name the destination sheet
' Strip Client name to extract the AU #
xValue = rngUniques2(counter, 1).Value
Debug.Print xValue
OutValue = ""
For xIndex = 1 To VBA.Len(xValue)
If (VBA.Mid(xValue, xIndex, 1) <> "-") Then
If VBA.IsNumeric(VBA.Mid(xValue, xIndex, 1)) Then
OutValue = OutValue & VBA.Mid(xValue, xIndex, 1)
End If
Else: Exit For
End If
Next
wbDest.Sheets(counter).Name = cell.Value & " - " & OutValue
wbDest.Sheets(counter).Cells.Columns.AutoFit
Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
编辑解释
示例数据：
A B
1个
1个
1个
2乙
2乙
3 C
3 C
3 C
3 C
4D
4D
4D
程序将 A 列中每个唯一项目的所有行复制到单独的选项卡，并尝试正确命名选项卡。给我带来麻烦的是选项卡的命名。我正在尝试获取以下格式的选项卡名称 "A value - B value"，因此对于上面的示例，将有四个名为：
的选项卡
1 - A
2 - B
3 - C
4 - D
rngUniques 包含 A 列的唯一值，rngUniques2 包含 B 列的相应值。我试图从同一个 For Each 循环中的两个范围读取，但它没有访问 rngUniques2 中的正确数据。例如，当我 运行 宏时，它会将选项卡命名为：
1 - A
2 - A
3 - B
4 - C
上面的小样本量让它看起来像是只有一项，但随着它的发展，它会越来越远。我的实际数据创建了 110 个单独的选项卡。我假设错误来自我尝试访问以下数据的方式。
xValue = rngUniques2(counter, 1).Value
在不同范围内使用 For Each 循环时，如何处理另一个范围内的数据？
好的，谢谢，最后的编辑确实很有帮助。
最后澄清一下：如果 A 列中的文本始终为“2”，那么 B 列中的文本是否始终为 "B"？或者有时 ColumnA 可能是 2 但 B 列可能是 "C"？因为对我来说，我认为你对 rnguniques2 进行任何检查都会使事情过于复杂。
假设列 B 对于每个唯一列 A 值都相同，您可以删除除初始 "set = column B" 之外对 rnguniques2 的所有引用，然后在设置 sheet 的名称时，只需go "rnguniques(counter,1).value & " - " & rnguniques(counter,2).value"
我真的看不出这部分代码的意义所在：
xValue = rngUniques2(counter, 1).Value
Debug.Print xValue
OutValue = ""
For xIndex = 1 To VBA.Len(xValue)
If (VBA.Mid(xValue, xIndex, 1) <> "-") Then
If VBA.IsNumeric(VBA.Mid(xValue, xIndex, 1)) Then
OutValue = OutValue & VBA.Mid(xValue, xIndex, 1)
End If
Else: Exit For
End If
Next
通过将 A 列和 B 列合并到 A 列中，我已经能够暴力破解它为我工作。
我在网上找到了以下大部分代码，它们对我来说非常有用。我添加的部分是创建第二个范围 rngUniques2 以及使用该范围进行一些字符串操作。我遇到的问题是，当我尝试访问该范围时，除了第一次外，它没有提取正确的值。我在想我用错了柜台，但我没能把它改正。我知道范围中有正确的值，因为我为每个单元格调试打印。
Sub Extract_All_Data()
'this macro assumes that your first row of data is a header row.
'will copy all filtered rows from one worksheet, to another blank workbook
'each unique filtered value will be copied to it's own sheet
'Variables used by the macro
Dim wbOrig, wbDest As Workbook
Dim rngFilter As Range, rngUniques, rngUniques2 As Range
Dim cell As Range, counter As Integer
Dim xValue, OutValue As String
' Prompt user to choose file and open it
MsgBox "Please select the file that will be split."
strFileToOpen = Application.GetOpenFilename(Title:="Please select the file that will be split.", FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen = "False" Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wbOrig = Workbooks.Open(Filename:=strFileToOpen)
End If
Sheets("HTPN").Activate
' Set the filter range (from A1 to the last used cell in column A)
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
' Filter column A to show only one of each item (uniques) in column A
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
' Set a variable to the Unique values (one for ClientID and one for Client Name)
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
Set rngUniques2 = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
' Clear the filter
ActiveSheet.ShowAllData
End With
' Create a new workbook with a sheet for each unique value
Application.SheetsInNewWorkbook = rngUniques.Count
Set wbDest = Workbooks.Add
Application.SheetsInNewWorkbook = 3
' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
For Each cell In rngUniques
counter = counter + 1
'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
' Copy and paste the filtered data to it's unique sheet
rngFilter.Resize(, 30).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
' Name the destination sheet
' Strip Client name to extract the AU #
xValue = rngUniques2(counter, 1).Value
Debug.Print xValue
OutValue = ""
For xIndex = 1 To VBA.Len(xValue)
If (VBA.Mid(xValue, xIndex, 1) <> "-") Then
If VBA.IsNumeric(VBA.Mid(xValue, xIndex, 1)) Then
OutValue = OutValue & VBA.Mid(xValue, xIndex, 1)
End If
Else: Exit For
End If
Next
wbDest.Sheets(counter).Name = cell.Value & " - " & OutValue
wbDest.Sheets(counter).Cells.Columns.AutoFit
Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
编辑解释
示例数据：
A B
1个
1个
1个
2乙
2乙
3 C
3 C
3 C
3 C
4D
4D
4D
程序将 A 列中每个唯一项目的所有行复制到单独的选项卡，并尝试正确命名选项卡。给我带来麻烦的是选项卡的命名。我正在尝试获取以下格式的选项卡名称 "A value - B value"，因此对于上面的示例，将有四个名为：
的选项卡1 - A
2 - B
3 - C
4 - D
rngUniques 包含 A 列的唯一值，rngUniques2 包含 B 列的相应值。我试图从同一个 For Each 循环中的两个范围读取，但它没有访问 rngUniques2 中的正确数据。例如，当我 运行 宏时，它会将选项卡命名为：
1 - A
2 - A
3 - B
4 - C
上面的小样本量让它看起来像是只有一项，但随着它的发展，它会越来越远。我的实际数据创建了 110 个单独的选项卡。我假设错误来自我尝试访问以下数据的方式。
xValue = rngUniques2(counter, 1).Value
在不同范围内使用 For Each 循环时，如何处理另一个范围内的数据？
好的，谢谢，最后的编辑确实很有帮助。
最后澄清一下：如果 A 列中的文本始终为“2”，那么 B 列中的文本是否始终为 "B"？或者有时 ColumnA 可能是 2 但 B 列可能是 "C"？因为对我来说，我认为你对 rnguniques2 进行任何检查都会使事情过于复杂。
假设列 B 对于每个唯一列 A 值都相同，您可以删除除初始 "set = column B" 之外对 rnguniques2 的所有引用，然后在设置 sheet 的名称时，只需go "rnguniques(counter,1).value & " - " & rnguniques(counter,2).value"
我真的看不出这部分代码的意义所在：
xValue = rngUniques2(counter, 1).Value
Debug.Print xValue
OutValue = ""
For xIndex = 1 To VBA.Len(xValue)
If (VBA.Mid(xValue, xIndex, 1) <> "-") Then
If VBA.IsNumeric(VBA.Mid(xValue, xIndex, 1)) Then
OutValue = OutValue & VBA.Mid(xValue, xIndex, 1)
End If
Else: Exit For
End If
Next
通过将 A 列和 B 列合并到 A 列中，我已经能够暴力破解它为我工作。