vba 在 Excel 中使用条件循环遍历列

Loop through columns with conditional if in Excel

提问by Justin

I'm needing to write an excel script to fill in some data. Essentially what needs to happen is the script should loop through each record and when it hits a "1" it should follow each cell with another "1" until it hits the next "1". My goal is to fill in the gaps between 1s with more 1s.

我需要编写一个excel脚本来填充一些数据。基本上需要发生的是脚本应该循环遍历每条记录，当它遇到“1”时，它应该跟随每个单元格与另一个“1”，直到它遇到下一个“1”。我的目标是用更多的 1 来填补 1 之间的空白。

Here's what I have so far:

这是我到目前为止所拥有的：

Dim i, j As Integer

finalrow = Cells(665, 1).End(x1up).Row
finalcol = Cells(1, 10).End(x1toleft).Column

For i = 1 To finalrow
    If Cells(i, j).Value = "0" Then
        For j = 1 To finalcol
            Next j
    Else
        For j = 1 To finalcol
            Next j
            Cells(i, j).Value = "1"
    End If
Next i

I keep getting an error when this is ran.

运行此程序时，我不断收到错误消息。

My data is structured like this:

我的数据结构如下：

0   0   1   0   0   0   1   0   0   0
1   0   0   1   0   0   0   0   0   0
0   0   0   1   0   0   1   0   0   0
0   0   0   1   1   0   0   0   0   0

Any help or advise is much appreciated.

非常感谢任何帮助或建议。

Thanks.

谢谢。

回答by ray

There are a few issues with your code (particularly that FOR LOOP doesn't make much sense).

您的代码存在一些问题（尤其是 FOR LOOP 没有多大意义）。

I took what you had and made comments and changed to quasi-fit what you are asking for.

我接受了你所拥有的并发表了评论，并更改为准符合你的要求。

Absorb:

吸收：

Option Explicit 'USE THIS!!!

Sub Test()

    'Dim i, j As Integer NO! "i" is Varaint and you want integer
    Dim i As Integer, j As Integer 'Use this syntax for single line declaration 
    'Adding "Option Explicit" makes you declare these two variables
    Dim finalRow As Integer
    Dim finalCol As Integer

    Dim oneFound As Boolean 'This will be used on the for loop


    finalRow = Range("A65536").End(xlUp).Row 'Do this.  I'm not sure your code works:  Cells(665, 1).End(xlUp).Row 'you had x1, not "XL" (typo)
    finalCol = Range("IV1").End(xlToLeft).Column ''Do this.  I'm not sure your code works:  Cells(1, 10).End(xlToLeft).Column 'had x1, not "XL" (typo)

    oneFound = False
    For i = 1 To finalRow 'You're looping through rows here, now you need to loop through columns

        'REASON FOR YOUR ERROR:  Variable j below is zero at this point and there is no cell (1,0).
        'If Cells(i, j).Value = "0" Then
        For j = 1 To finalCol
            If Cells(i, j).Value = 1 And Not oneFound Then 'We found a one in a cell and we haven't started in filling ones yet
                oneFound = True
            ElseIf Cells(i, j).Value <> 1 And oneFound Then 'You found a one previously in the row and you want to start filling in data
                Cells(i, j).Value = 1
            ElseIf Cells(i, j).Value = 1 And oneFound Then 'You found a one previously in the row and you just found your next one
                'Don't know what you want to do here
                'Setting oneFound to false in case you want to stop filling in data
                oneFound = False
            Else
              'All scenarioes should be covered for what you asking above.
              'You could do something else here should you find the need
            End If
        Next j

        oneFound = False 'Reinitialize for next row
    Next i


End Sub

回答by Robert Mearns

If all you are trying to do is replace zeros with ones, instead of looping through the data you could use search and replace functionality.

如果您要做的只是用 1 替换零，那么您可以使用搜索和替换功能，而不是遍历数据。

Cells.Select
Selection.Replace What:="0", Replacement:="1"

回答by user1934049

Sub abc()

j = 2
ActiveSheet.Range("a1").Select
ActiveSheet.Range("a65536").Select
lastrow = Selection.End(xlUp).Row

'/// column a
ActiveSheet.Range("a3:a" & lastrow).Select

    Selection.AutoFilter
    ActiveSheet.Range("$A:$A$" & lastrow).AutoFilter Field:=1, Criteria1:="="

    Application.CutCopyMode = False

    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    lrow = ActiveSheet.Range("A65536").End(xlUp).Row
    ActiveSheet.Range("a" & lrow).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
 Selection.AutoFilter

'column b///////////
ActiveSheet.Range("b3:b" & lastrow).Select

    Selection.AutoFilter
    ActiveSheet.Range("$b:$b$" & lastrow).AutoFilter Field:=1, Criteria1:="="

    Application.CutCopyMode = False
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    lrow = activehseet.Range("A65536").End(xlUp).Row
    ActiveSheet.Range("a" & lrow).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
     Selection.AutoFilter

    'column c////////////

 ActiveSheet.Range("c3:c" & lastrow).Select

    Selection.AutoFilter
    ActiveSheet.Range("$c:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="SG Plus", _
    Operator:=xlOr, Criteria2:="=Select"
    Application.CutCopyMode = False
    Range(Selection, Selection.End(xlToRight)).Select
'    Selection.Copy
'    Sheets("Sheet2").Select
'    lrow = activehseet.Range("A65536").End(xlUp).Row
'    ActiveSheet.Range("a" & lrow).Select
'    ActiveSheet.Paste
'    Sheets("Sheet1").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
    Selection.AutoFilter


'column c again/////////////
ActiveSheet.Range("c3:c" & lastrow).Select

    Selection.AutoFilter
    ActiveSheet.Range("$c:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="="

    Application.CutCopyMode = False
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    lrow = activehseet.Range("A65536").End(xlUp).Row
    ActiveSheet.Range("a" & lrow).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
     Selection.AutoFilter

'//////////////////////////// changes oct 21 end


ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("a" & i).Select
If Range("a" & i).Value = "MidAmerica" Or Range("a" & i).Value = "Northeast" Or Range("a" & i).Value = "Southeast" Or _
Range("a" & i).Value = "West" Then
GoTo cont
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    Range("a" & j).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
       Selection.Delete Shift:=xlUp
   End If
cont:
Next i


'/////// column b ///////////

ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("b" & i).Select
If Range("b" & i).Value = "CA" Or Range("b" & i).Value = "AZ" Then
GoTo cont2
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    Range("a" & j).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont2:
Next i

'///////////column c //////////

ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("c" & i).Select
If Range("c" & i).Value = "SG" Then
GoTo cont3
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    Range("a" & j).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont3:
Next i

'//////////column l/////////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("l" & i).Select
If Range("l" & i).Value >= "01/01/2014" And Range("l" & i).Value <= "30/06/2014" Then
GoTo cont4
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    Range("a" & j).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont4:
Next i

'//////////column m/////////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("m" & i).Select
If Range("m" & i).Value >= "12/01" Or Range("m" & i).Value <= "12/05" Then
GoTo cont5
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    Range("a" & j).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont5:
Next i

'//////////column q and r/////////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("q" & i).Select
If Range("q" & i).Value <> " " And Range("r" & i).Value <> " " And Range("u" & i).Value <> " " _
And Range("z" & i).Value <> " " And Range("aa" & i).Value <> " " And Range("ab" & i).Value <> " " _
And Range("b" & i).Value <> " " And Range("j" & i).Value <> " " Then
GoTo cont6
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    Range("a" & j).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont6:
Next i


End Sub

回答by Our Man in Bananas

you could do that with the use of a formula and replace the existing values like this:

您可以使用公式来做到这一点，并像这样替换现有值：

Sub Test2()

Dim iRow As Integer
Dim iDx As Integer
Dim iLastRow As Integer
Dim sConcatValues As String
Dim sFormula As String

    sConcatValues = "A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J"

    sFormula = "=LEFT(" & sConcatValues & ",FIND(""1""," _
                        & sConcatValues & ")) & REPT(""1"",FIND(""1""," _
                        & sConcatValues & ",FIND(""1""," _
                        & sConcatValues & ")+1)-1-FIND(""1""," _
                        & sConcatValues & ")) & MID(" _
                        & sConcatValues & ",FIND(""1""," _
                        & sConcatValues & ",FIND(""1""," _
                        & sConcatValues & ")+1),LEN(" _
                        & sConcatValues & "))"

    iLastRow = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row

    iRow = 1

    ' put in the formula to fix the values
    Range("L1:L" & iLastRow).Formula = sFormula
    Range("L1:L" & iLastRow).Copy
    Range("L1:L" & iLastRow).PasteSpecial xlPasteValues

    ' now copy over the new values, and clean up!
    For iRow = 1 To iLastRow
        For iDx = 1 To Len(Range("L" & iRow).Text)
            Cells(iRow, iDx) = Mid(Range("L" & iRow).Text, iDx, 1)
        Next
    Next

    Range("L1:L" & iLastRow).Clear
    'Range("A1").Activate

End Sub

this is the formula that is used:

这是使用的公式：

=LEFT(A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)) & REPT("1",FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)+1)-1-FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)) & MID(A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)+1),LEN(A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J))

basically you concatenate the cells, then do a find for the first 1, followed by the next 1, and fill in between using the REPTfunction

基本上你连接单元格，然后对第一个进行查找1，然后是下一个1，然后使用REPT函数填充

Philip

菲利普

回答by user1644564

Including this might help as well.

包括这也可能有所帮助。

http://msdn.microsoft.com/en-us/library/office/aa213567%28v=office.11%29.aspx

http://msdn.microsoft.com/en-us/library/office/aa213567%28v=office.11​​%29.aspx

Cells.SpecialCells(xlCellTypeLastCell)

Instead of using

而不是使用

finalRow = Range("A65536")...
finalCol = Range("IV1").End(xlToLeft).Column