I'm writing a simple formatting macro to alternate the row color for a table in Excel.
I want this macro to be able to format any size table (no matter row/column size).
For example, I want the macro to work when I have a chart with 6 rows 4 columns, or 4 rows 5 columns, or 9 rows 10 columns, etc.
Here's the code I have so far - but I'm getting a runtime error.
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
For Each Cell In Range(lastRow, lastCol) ''change range accordingly
If Cell.Row Mod 2 = 1 Then
Cell.Interior.ColorIndex = 15 ''color to preference
Else
Cell.Interior.ColorIndex = 14 ''color to preference or remove
End If
Next Cell
End If
I've tried multiple versions of the Range - having the column var come first, having an '&' instead of a comma, etc.
If I use just Range("A1:A" & lastRow), it'll work but just for the data in column A.
I would need it to span across all columns in the chart.
If the tables are all starting from cell A1, change your for statement to:
For Each Cell In Range("A1", Cells(lastRow, lastCol)) ''change range accordingly
Though also, the way your for loop works is that it is changing every cell. It can be optimized to color the row up to the last column at once.
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
Dim i As Integer
For i = 1 To lastRow
If i Mod 2 = 1 Then
Range("A" & i, Cells(i, lastcol)).Interior.ColorIndex = 15
Else
Range("A" & i, Cells(i, lastcol)).Interior.ColorIndex = 14
End If
Next i
End If
Try this:
Dim r As Range
For Each r In MyWs.UsedRange.Rows
If r.Row Mod 2 = 1 Then
r.Interior.ColorIndex = 15
Else
r.Interior.ColorIndex = 14
End If
Next r
Always good to include Option Explicit in your code modules. Try the following:
Option Explicit
Sub test()
Dim MyWS As Excel.Worksheet
Dim objRow As Excel.Range
Dim lastCol As Long
Dim lastRow As Long
Dim lngRow As Long
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
For lngRow = 1 To lastRow
Set objRow = MyWS.Range(MyWS.Cells(lngRow, 1), MyWS.Cells(lngRow, lastCol))
If lngRow Mod 2 = 1 Then
objRow.Interior.ColorIndex = 15 'color to preference
Else
objRow.Interior.ColorIndex = 14 'color to preference or remove
End If
Next lngRow
End If
End Sub
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I have the following VBA code for excel
Dim k As Integer, z As Integer
Dim sourceSht As Worksheet
Dim destSht As Worksheet
z = 0
Set sourceSht = Sheets("sheet1")
Set destSht = Sheets("sheet2")
DoEvents
For k = 1 To 5000
If k < 3 Or (k - 1) Mod 3 <> 0 Then
z = z + 1
sourceSht.Columns(k).Copy destSht.Columns(z)
End If
Next
This code was working perfectly for rows (changed this part"sourceSht.Columns(k).Copy destSht.Columns(z)").
but I can not make it work for columns. I want excel to copy the first 2 columns then skip the third one, then copy 2 again, skip one and etc... can somebody help me and explain what am I doing wrong?
I'm going to ignore the use of mod and do a Step 3 with the loop:
Dim i as Long, j as Long
For i = 1 to 5000 Step 3
With sourceSht
If j = 0 Then
j = 1
Else
j = j + 2 'Copying 2 columns over, so adding 2 each time
End If
.Range(.Columns(i),.Columns(i+1)).Copy destSht.Range( destSht.Columns(j), destSht.Column(j+1))
End With
Next i
Something like that should do it for you
Alternate:
Sub tgr()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rCopy As Range
Dim rLast As Range
Dim LastCol As Long
Dim i As Long
Set wsSource = ActiveWorkbook.Sheets("Sheet1")
Set wsDest = ActiveWorkbook.Sheets("Sheet2")
On Error Resume Next
Set rLast = wsSource.Cells.Find("*", wsSource.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
On Error GoTo 0
If rLast Is Nothing Then Exit Sub 'No data
LastCol = rLast.Column
Set rCopy = wsSource.Range("A:B")
For i = 4 To LastCol Step 3
Set rCopy = Union(rCopy, wsSource.Columns(i).Resize(, 2))
Next i
rCopy.Copy wsDest.Range("A1")
End Sub
Try this (use count for the number of time you need to copy columns, t for the first columns you need to copy):
Sub copy_columns()
t = 1
Count = 1
Do Until Count = 10
Range(Columns(t), Columns(t + 1)).Copy
Cells(1, t + 3).Select
Selection.PasteSpecial Paste:=xlPasteValues
t = t + 3
Count = Count + 1
Loop
End Sub
I wanted to add a row in excel vba when ever the value in column A is 1, here is the code I wrote, but this returns a "subscript out of range error". What am I doing wrong?
Sub InsertRow()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Application.ScreenUpdating = False
Col = "A"
StartRow = 1
LastRow = 20
Worksheets("Sheet1").Activate
For R = StartRow To LastRow
If Cells(R, Col) = 1 Then
Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
Application.ScreenUpdating = True
End Sub
Code below tested and works.
With Worksheets("Sheet1")
Dim cntr as Long
For cntr = 20 to 5 Step - 1
If .Cells(cntr, 1) = 1 Then .cells(cntr,1).EntireRow.Insert Shift:=xlDown
Next
End With
Sub InsertRow()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Application.ScreenUpdating = False
Col = "A"
StartRow = 1
LastRow = 20
Worksheets("Sheet1").Activate
R = StartRow
Do While R <= LastRow
If Cells(R, Col) = 1 Then
Cells(R, Col).EntireRow.Insert Shift:=xlDown
R = R + 1
LastRow = LastRow + 1
End If
R = R + 1
Loop
Application.ScreenUpdating = True
End Sub
Note the setting of the value of R in the loop, as you are shifting the rows down, you are continually checking the same value and therefore adding a row each time so we need to increment R by 1 to skip past the 1 we just checked.
We also need to change the endpoint as we are pushing values past Row 20 by inserting so we also increment the LastRow variable. We cannot do this in a for loop in VBA, the for loop will terminate at 20 so I have changed to a while loop
As per the comment below, working backwards from 20 is far more elequent but since I didn't think of that I haven't put it in here :)
I have a loop towards the bottom of my code that successfully loops through my data and clears out all rows where Column H = 0.
However, there are several cells in column B displaying #REF!. I would also like this loop to delete those rows in the same manner as it does the 0s in column H.
I think my issue is not knowing how to reference those types of errors. Treating #REF! like a string doesn't appear to be working.
Thank you!
Sub test()
Dim currentSht As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim startCell As Range
Dim r As Integer
Set startCell = Sheets("Sheet1").Range("A1")
Set currentSht = ActiveWorkbook.Sheets("Sheet1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row '<~~ Not sure why, but do not use "Set" when defining lastRow
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For r = 1 To lastRow Step -1
If currentSht.Cells(r, "H").Value = 0 Or currentSht.Cells(r, "B").Text = "#REF!" Then
Rows(r).Select
Selection.EntireRow.Delete
End If
Next r
currentSht.Range(startCell, currentSht.Cells(lastRow, lastCol)).Select
End Sub
I think I see your problem:
For r = 1 To lastRow Step -1
Change that line to
For r = lastrow to 1 Step -1
How about this code:
Sub Delete0()
Dim F As Integer
Dim Y As Integer
Dim RngCount As Range
Set RngCount = ActiveSheet.Range("H:H")
Y = Application.WorksheetFunction.CountA(RngCount)
For F = Y To 1 Step -1
If IsError(ActiveSheet.Range("H" & F)) Then
ActiveSheet.Rows(F).EntireRow.Delete
ElseIf ActiveSheet.Range("H" & F).Value = 0 Then
ActiveSheet.Rows(F).EntireRow.Delete
End If
Next F
End Sub
I have an excel table that has some duplicates and we currently have a count of these however I want to populate a unique number for each duplicate. e.g.
Number Count Sequence
1 2 1
1 2 1
2 3 2
2 3 2
2 3 2
3 4 3
3 4 3
3 4 3
3 4 3
4 2 4
4 2 4
5 5 5
5 5 5
5 5 5
5 5 5
5 5 5
I was playing with the following IF statement but I want it to check through the whole range and check if it has any in a wrong order but still the same.
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
is this possible?
It will add the unique ref into the a Column which is 3 columns up from what every you set col equal to.
It also requires that col + 3 to be blank, this will make the checking easier.
Sub SomeSub()
Dim Array1 As Variant
Dim Array2 As Variant
With ActiveSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
'Setting up the array for assigning each row value to the array
ReDim Array1((LastRow + 1))
ReDim Array2((LastRow + 1))
'Here youwill set what column is the "Number" Column
col = 1
'Assigning the row data into the arrays
'Starting at 2 to skip the title row
For r = 2 To LastRow
'Values in Column 1 go to Array1
Array1(r) = Cells(r, col)
'Values in Column 2 go to Array2
Array2(r) = Cells(r, col + 1)
Next r
'Setting unquie ref to 1
Seq = 1
'Running through each row of data
For i = 2 To LastRow
'col + 3 refers to a column on beyond the Sequence colum
'If the column is blank then that row has not been checked yet
If Cells(i, col + 3) = "" Then
'Assign the Uniqui ref to the row
Cells(i, col + 3).Value = Seq
'Running through the rest of the rows to check if they are like the current row
For n = i + 1 To (LastRow)
'If cell is blank then the row has been checked
If Cells(n, col + 3) = "" Then
'Array(i) is the current row
'Array(n) are the leading rows after row i
'If the current row is the same as any leading row then the uniquie ref = seq
If Array1(i) = Array1(n) And Array2(i) = Array2(n) Then Cells(n, col + 3).Value = Seq
'Else a value has been added
Else
'Do nothing
End If
Next n
'Increment the seq
Seq = Seq + 1
'Ending the If Cells(i, col + 3) = "" Then
End If
Next i
End Sub
You can first loop through the column and get the unique items using collections.
This part of the code:
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
Will only get the unique items, as a collection of items cannot have duplicates.
Use this to Number the duplicates.Change the sheet name as required.
Sub NumberDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
.Columns("B:B").ClearContents
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 1
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Offset(, 1) = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
Use this to Color the Duplicates, this will work on a small scale, depends on how many unique items there are, it's cool example though. Edited code from my answer here.
Sub ColorDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Interior.ColorIndex = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
In C1 just 1 and in C2:
=MIN(IF(($A$2:A2=A3)*($B$2:B2=B3),$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
and simply autofill down from C3
hmm... i think i got it wrong :/
if only looking at Column A then this should be enough:
=MIN(IF($A$2:A2=A3,$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
looking at your formula it can be shortened:
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
'IF(A2=A1,TRUE,FALSE)=FALSE ==>> A1<>A2
=IF(IF(A1<>A2,1,0)>=0,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(A1<>A2,1,0)>=0 ==>> TRUE
=IF(TRUE,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(TRUE => allways true
=IF(A1<>A2,1,0)+D1
'last skip
=D1+(A1<>A2)