Welcome to OGeek Q&A Community for programmer and developer-Open, Learning and Share
Welcome To Ask or Share your Answers For Others

Categories

0 votes
263 views
in Technique[技术] by (71.8m points)

excel - Apply VBA script to multiple rows and cells

I'm completely new to VBA(this is my first from scratch script) but before i spend hours upon hours searching how to get this done i'll ask here.

So here's my problem.

After much searching and trying I managed to get this code:

Sub ColorChange()

Dim ws As Worksheet
Set ws = Worksheets(2)

clrOrange = 39423
clrWhite = RGB(255, 255, 255)

If ws.Range("D19").Value = "1" And ws.Range("E19").Value = "1" Then
    ws.Range("D19", "E19").Interior.Color = clrOrange
ElseIf ws.Range("D19").Value = "0" Or ws.Range("E19").Value = "0" Then
    ws.Range("D19", "E19").Interior.Color = clrWhite
End If

End Sub

This works as i need it, but now i need this code to work in 50 rows and 314 cells, but everytime only on two cells so, D19+E19, D20+E20, etc. Endpoint is DB314+DC314 Is there an easy way to get this done, without needing to copy paste this code and replacing all the row and cells by hand?

It also would be nice that if the value in the two cells is anything other than 1+1 the cell color changes back to white.

This is probably some really basic stuff, it's just pretty hard to find without reading through a mountain of tutorials/questions/examples.

Thanks!

EDIT: So the solution has been found(read: thrown in my lap) thanks to @VBasic2008. I only needed to add the following to the sheets code to get the solution to work automatically:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D19:DC314")) Is Nothing Then
Call ColorChange
End If
End Sub

And because Interior.Color removes border's i added the following sub:

Sub vba_borders()

Dim iRange As Range
Dim iCells As Range

Set iRange = Range("D19:DC67,D70:DC86,D89:DC124,D127:DC176,D179:DC212,D215:DC252,D255:DC291,D294:DC314")

For Each iCells In iRange
    iCells.BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin
            
Next iCells

End Sub

The Range is a bit different to exclude some row's

question from:https://stackoverflow.com/questions/65883902/apply-vba-script-to-multiple-rows-and-cells

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
Welcome To Ask or Share your Answers For Others

1 Reply

0 votes
by (71.8m points)

Compare Values in the Two Cells of Column Pairs

Option Explicit

Sub ColorChange()
    
    Const rgAddress As String = "D19:DC314"
    Const Orange As Long = 39423
    Const White As Long = 16777215
    
    Dim wb As Workbook ' (Source) Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    Dim rg As Range ' (Source) Range
    Set rg = wb.Worksheets(2).Range(rgAddress) ' Rather use tab name ("Sheet2").

    Dim cCount As Long ' Columns Count
    cCount = rg.Columns.Count
    
    Dim brg As Range ' Built Range
    Dim rrg As Range ' Row Range
    Dim crg As Range ' Two-Cell Range
    Dim j As Long ' (Source)/Row Range Columns Counter
    
    For Each rrg In rg.Rows
        For j = 2 To cCount Step 2
            Set crg = rrg.Cells(j - 1).Resize(, 2)
            If crg.Cells(1).Value = 1 And crg.Cells(2).Value = 1 Then
                If brg Is Nothing Then
                    Set brg = crg
                Else
                    Set brg = Union(brg, crg)
                End If
            End If
        Next j
    Next rrg
    
    Application.ScreenUpdating = False
    rg.Interior.Color = White
    If Not brg Is Nothing Then
        brg.Interior.Color = Orange
    End If
    Application.ScreenUpdating = True

End Sub

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
OGeek|极客中国-欢迎来到极客的世界,一个免费开放的程序员编程交流平台!开放,进步,分享!让技术改变生活,让极客改变未来! Welcome to OGeek Q&A Community for programmer and developer-Open, Learning and Share
Click Here to Ask a Question

...