循环超出第一个循环

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

如果有人需要更清晰的图片，这就是我要尝试的方法 Picture of what im trying to do

感谢您的帮助

Answer 1

可以尝试

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

输入范围选择不包括“行标签”列，对于目标范围的第一个单元格的输出范围选择将进行。

Answer 2

通过这种方式浏览每一列。

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