Неисправность доступа к двойным диапазонам

Question

Я нашел большую часть следующего кода онлайн, и это работает для меня потрясающе. Часть, которую я добавил, - это создание второго диапазона 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 A

1 A

1 A

2 B

2 Б

3 С

3 С

3 С

3 С

4 D

4 D

4 D

Программа копирует все строки каждого уникального элемента в столбце A, чтобы разделить вкладки и попытаться правильно назвать вкладку. Это именование вкладки, которая вызывает у меня проблемы. Я пытаюсь получить название вкладки в следующем формате «значение - значение B», так что для приведенного выше примера, там будет четыре вкладки под названием:

1 -

2 - B

3 - с

4 - Д

rngUniques содержит уникальные значения из колонки а и rngUniques2 содержит соответствующие значения из столбца B. Я пытаюсь читать из обоих диапазонов в том же для каждого цикла, но не получает правильные данные в rngUni ques2. Например, когда я запустить макрос, это было бы назвать вкладки:

1 -

2 -

3 - B

4 - С

Небольшой размер выборки выше, похоже, что это только один элемент, но он уходит дальше, как он идет. Мои фактические данные создают 110 отдельных вкладок. Я предполагаю, что ошибка исходит из того, как я пытаюсь получить доступ к данным ниже.

xValue = rngUniques2(counter, 1).Value 

Как бы я продвигался по данным другого диапазона при использовании для каждой петли в другом диапазоне?

Answer 1

я был способный к грубой силе, чтобы это работало для меня, просто объединив столбцы А и В в колонку А.

Answer 2

ОК, спасибо, последнее редактирование действительно помогает.

Заключительное разъяснение: Если текст в столбце A всегда, скажем, «2», это текст в столбце B всегда, скажем, «B»? Или бывают случаи, когда ColumnA может быть 2, но столбец B может быть «C»? Потому что для меня, я думаю, вы слишком сильно себя чувствуете, делая какие-либо проверки rnguniques2 вообще.

Предполагая, что столбец B одинаковый для каждого уникального столбца Значение, вы можете удалить все ссылки на rnguniques2, за исключением начального «set = column B», а затем при настройке имени листа просто перейдите «rnguniques (счетчик, 1) .value & "-" & rnguniques (счетчик, 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