первый цикл

Question

Мой код продолжает проходить от следующей ячейки до следующей петли столбца, кто-нибудь может помочь с этим? главная цель состоит в том, чтобы выделить весь диапазон с помощью Input Rng и прочитать значение красного цвета в каждом из столбцов и вернуть номер регистра слева в смещении выходного столбца для каждого столбца каждой ячейки.

ObtainSCEs()
Dim InputRng As Range
Dim OutputRng As Range
Dim Rng As Range

xTitleID = "ObtainSCE"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("select data Range:", xTitleID, InputRng.Address, Type:=8)
Set OutputRng = Application.InputBox("select output Range:", xTitleID, Type:=8)
Dim C As Long
C = 0
Dim B As Long
B = InputRng.Columns.Count
Dim A As Long
A = 1
Dim Cell As Range
Dim Column As Range
    For Each Column In InputRng
        For Each Cell In Column
           If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
               If Len(OutputRng.Offset(0, 0)) > 0 Then
               OutputRng.Offset(0, C).Value = OutputRng.Offset(0, C).Value & ","
               OutputRng.Offset(0, C).Value = OutputRng.Offset(0, C) & Cell.Offset(0, -1 - C).Value
               Else
                OutputRng.Offset(0, C) = Cell.Offset(0, -1 - C).Value
            End If
            End If
        Next Cell

        Next Column


End Sub

У меня есть второй код, который я пытался использовать другим подходом, но он продолжает работать с первым столбцом непрерывно. Показано ниже

  Sub ObtainSCEs()
Dim InputRng As Range
Dim OutputRng As Range
Dim Rng As Range

xTitleID = "ObtainSCE"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("select data Range:", xTitleID, InputRng.Address, Type:=8)
Set OutputRng = Application.InputBox("select output Range:", xTitleID, Type:=8)
Dim C As Long
C = 0
Dim B As Long
B = InputRng.Columns.Count
Dim A As Long
A = 0
Dim Cell As Range
Dim Column As Range

    For n = 1 To 5
    InputRng.Columns(n).Select

        For Each Cell In InputRng.Columns.Cells
           If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
               If Len(OutputRng.Offset(0, 0)) > 0 Then
               OutputRng.Offset(0, C) = OutputRng.Offset(0, C).Value & ","
               OutputRng.Offset(0, C) = OutputRng.Offset(0, C) & Cell.Offset(0, -1 - C).Value
               Else
                OutputRng.Offset(0, C) = Cell.Offset(0, -1 - C).Value
                End If
            End If
        Next Cell
        C = C + 1
    Next n


End Sub

Это код, который я сейчас использую для этого, сейчас я вручную выбираю все 6 столбцов, но я хочу выбрать 1 весь диапазон, а затем разделить диапазон на соответствующие столбцы.

Sub GetSCE()
Application.Volatile True
Dim Rng As Range
Dim InputRng1 As Range, OutputRng As Range
Dim InputRng2 As Range, InputRng3 As Range
Dim InputRng4 As Range, InputRng5 As Range
Dim InputRng6 As Range
Dim Cell As Range
Dim sev1 As Integer
sev1 = 1
Dim sev2 As Integer
sev2 = 2
Dim sev3 As Integer
sev3 = 3
Dim sev4 As Integer
sev4 = 4
Dim sev5 As Integer
sev5 = 5
Dim sev6 As Integer
sev6 = 6
xTitleID = "ObtainSCE"
Set InputRng1 = Application.Selection
Set InputRng1 = Application.InputBox("Select Data Range1:", xTitleID, InputRng1.Address, Type:=8)
Set InputRng2 = Application.InputBox("Select Data Range2:", xTitleID, Type:=8)
Set InputRng3 = Application.InputBox("Select Data Range3:", xTitleID, Type:=8)
Set InputRng4 = Application.InputBox("Select Data Range4:", xTitleID, Type:=8)
Set InputRng5 = Application.InputBox("Select Data Range5:", xTitleID, Type:=8)
Set InputRng6 = Application.InputBox("Select Data Range6:", xTitleID, Type:=8)
Set OutputRng1 = Application.InputBox("Select Starting Cells:", xTitleID, Type:=8)
Set OutputRng2 = Application.InputBox("Select Starting Cells:", xTitleID, Type:=8)
Set OutputRng3 = Application.InputBox("Select Starting Cells:", xTitleID, Type:=8)
Set OutputRng4 = Application.InputBox("Select Starting Cells:", xTitleID, Type:=8)
Set OutputRng5 = Application.InputBox("Select Starting Cells:", xTitleID, Type:=8)
Set OutputRng6 = Application.InputBox("Select Starting Cells:", xTitleID, Type:=8)
    For Each Cell In InputRng1
        If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
            If Len(OutputRng1) > 0 Then OutputRng1.Value = OutputRng1.Value & ","
            OutputRng1.Value = OutputRng1.Value & Cell.Offset(0, -sev1).Value
            Else
        End If
    Next Cell
    For Each Cell In InputRng2
        If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
            If Len(OutputRng2) > 0 Then OutputRng2.Value = OutputRng2.Value & ","
            OutputRng2.Value = OutputRng2.Value & Cell.Offset(0, -sev2).Value
            Else
        End If
    Next Cell
        For Each Cell In InputRng3
        If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
            If Len(OutputRng3) > 0 Then OutputRng3.Value = OutputRng3.Value & ","
            OutputRng3.Value = OutputRng3.Value & Cell.Offset(0, -sev3).Value
            Else
        End If
    Next Cell
        For Each Cell In InputRng4
        If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
            If Len(OutputRng4) > 0 Then OutputRng4.Value = OutputRng4.Value & ","
            OutputRng4.Value = OutputRng4.Value & Cell.Offset(0, -sev4).Value
            Else
        End If
    Next Cell
        For Each Cell In InputRng5
        If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
            If Len(OutputRng5) > 0 Then OutputRng5.Value = OutputRng5.Value & ","
            OutputRng5.Value = OutputRng5.Value & Cell.Offset(0, -sev5).Value
            Else
        End If
    Next Cell
        For Each Cell In InputRng6
        If Cell.DisplayFormat.Interior.ColorIndex = 3 Then
            If Len(OutputRng6) > 0 Then OutputRng6.Value = OutputRng6.Value & ","
            OutputRng6.Value = OutputRng6.Value & Cell.Offset(0, -sev6).Value
            Else
        End If
    Next Cell
End Sub

Это то, что я пытаюсь сделать, если кому-то нужна более четкая картина Изображение того, что я пытаюсь сделать

Спасибо за помощь

Answer 1

Таким образом, вы проходите через каждый столбец.

Sub ObtainSCEs()

Dim InRng As Range
Dim OutRng As Range
BoxTitle = "ObtainSCE"
Set InRng = Application.InputBox("Select Data Input Range", BoxTitle, , Type:=8)
Set OutRng = Application.InputBox("Select Data Output Range", BoxTitle, , Type:=8)

Dim cll As Range
Dim col As Range

For Each col In InRng.Columns
    For Each cll In InRng
        If cll.Column = col.Column Then
            '...
            'whatever you want to do
            '...
        End If
    Next cll
Next col


End Sub

Answer 2

Может попробовать

Sub ObtainSCEs()
Dim InputRng As Range
Dim OutputRng As Range
Dim Rw  As Long
Dim Col As Long

xTitleID = "ObtainSCE"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("select data Range:", xTitleID, InputRng.Address, Type:=8)
Set OutputRng = Application.InputBox("select output Range:", xTitleID, Type:=8)
Dim A As Long
Dim B As Long
Dim C As Long

Dim Cell As Range
Dim Column As Range

    For Col = 1 To InputRng.Columns.Count
        For Rw = 1 To InputRng.Rows.Count
        If InputRng(Rw, Col).Interior.ColorIndex = 3 Then
        Valx = InputRng(Rw, 1).Offset(0, -1).Value
               If Len(OutputRng.Offset(0, Col - 1)) > 0 Then
               OutputRng.Offset(0, Col - 1).Value = OutputRng.Offset(0, Col - 1).Value & "," & Valx
               Else
               OutputRng.Offset(0, Col - 1) = Valx
               End If
        End If
     Next Rw
     Next Col

End Sub

Выбор входного диапазона исключает столбец меток строк, для выбора выходного диапазона первой ячейки целевого диапазона.