I want to run a macro on selected cells - where the macro compares a cell to it's neighbor beneath him - changes their color and moves on to the next pair of cells.
it's A 1 dimension array where I want to compare each pair of cells (1st with the 2nd, 3rd with the 4th etc.)
I tried working with
For Each cell In Selection
but then I don't know how to compare the given cell to the one beneath it.
Below is the sample code.
Sub compare()
Dim rng As Range, cell As Range
Set rng = Selection '
For Each cell In rng
'makes comparison
'offset(1,0) is used to find one cell below active cell
If cell.Value = cell.Offset(1, 0) Then
cell.Offset(1, 0).Interior.Color = vbRed
End If
Next
End Sub
Updated answer
Sub compare()
Dim rows As Long
rows = Selection.rows.Count - 1
Dim selCol As Long
selCol = ActiveCell.Column
Dim selRow As Long
selRow = ActiveCell.Row
For i = selRow To (selRow + rows)
If Cells(i, selCol) = Cells(i, selCol + 1) Then
Range(Cells(i, selCol), Cells(i, selCol + 1)).Interior.Color = vbYellow
End If
Next
End Sub
Sub compareCells()
Dim i As Integer
'Check dimension
If Selection.Columns.Count <> 1 Then
MsgBox "not 1d array"
Exit Sub
End If
'Check size
If Selection.Rows.Count Mod 2 <> 0 Then
MsgBox "size not even"
Exit Sub
End If
For i = 1 To Selection.Count / 2
With Selection
If .Cells(2 * i - 1) = .Cells(2 * i) Then
'what you want to do here, for e.g. , change color
.Cells(2 * i).Interior.Color = vbYellow
Else
'what you want to do here
'MsgBox "neq"
End If
End With
Next i
End Sub
Related
I'm using this code to check if the cell is a number or not to delete it, but there are 3 columns that I have to do this. But Do Until only goes through it once and stops doing it, leaving the loop.. it changes the col to 5 or 8 as it is in the for
Could someone help me with what I'm doing wrong in this code?
Another problem I have encountered is that if the cell is empty, vba fills in 0 as a value, is there a way to leave the cell blank instead of putting 0?
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 1
For Col = 2 To 8 Step 3
Do Until Cells(Row, 1).Value = ""
If IsNumeric(Cells(Row, Col)) = False Then
Cells(Row, Col).Clear
Else
Cells(Row, Col).Select
If Cells(Row, Col).Value = 0 Then
Cells(Row, Col).Value = (Cells(Row, Col).Value) * 1
Cells(Row, Col).NumberFormat = "$ #,##0.00"
Else
Cells(Row, Col).Value = CDec((Cells(Row, Col).Value))
Cells(Row, Col).NumberFormat = "$ #,##0.00"
End If
End If
Row = Row + 1
Loop
Next
End Sub
You can loop through the columns, but use special cells to determine if it is text or a number.
Based on your comment, it is either text or numbers, not sure why you would need to times by 1, or make value=value.
Sub UsingSpecialCells()
Dim ws As Worksheet
Dim rng As Range, LstRw As Long
Set ws = ActiveSheet
With ws
For Col = 2 To 8 Step 3
LstRw = .Cells(.Rows.Count, Col).End(xlUp).Row
Set rng = .Range(.Cells(2, Col), .Cells(LstRw, Col))
On Error Resume Next
rng.SpecialCells(xlCellTypeConstants, 2).ClearContents
On Error GoTo 0
On Error Resume Next
rng.SpecialCells(xlCellTypeConstants, 21).NumberFormat = "$#,##0.00"
On Error GoTo 0
Next
End With
End Sub
Clean Data: Apply Consistent Formatting in Columns
Option Explicit
Sub UpdateCurrency()
' Define constants.
Const FIRST_ROW As Long = 2 ' adjust: you have headers, right?
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Hard to believe that you know the column numbers but not the worksheet name.
' Calculate the last row, the row of the bottom-most non-empty cell
' in the worksheet.
Dim lCell As Range
Set lCell = ws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data
Dim LastRow As Long: LastRow = lCell.Row
Dim crg As Range, cell As Range, cValue, Col As Long
For Col = 2 To 8 Step 3 ' to not introduce further complications
' Reference the single-column range from the first to the last row.
Set crg = ws.Range(ws.Cells(FIRST_ROW, Col), ws.Cells(LastRow, Col))
' Clear the undesired values (all except empty and numeric values).
For Each cell In crg.Cells
' Write the cell value to a variant variable.
cValue = cell.Value
' Check if the value is not numeric.
If Not IsNumeric(cValue) Then cell.ClearContents
Next cell
' Apply the formatting to the whole column range so it takes effect
' if you decide to add numbers to the empty cells.
crg.NumberFormat = "$ #,##0.00" ' "\$ #,##0.00" if $ is not native
' Copy the values to memory, and copy them back to the range
' for the formatting to affect the remaining numerics
' (numbers and numbers formatted as text).
crg.Value = crg.Value
Next Col
MsgBox "Currency updated.", vbInformation
End Sub
Once iteration through the column 2 last row value is complete, blank row gets iterated and as per the condition Cells(Row, 1).Value = "" gets true and terminates the do until loop.
I have made small changes to your code and created the perfect working solution.
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 1
Dim row_i As Integer
row_i = Cells(1, 2).End(xlDown).Row
For Col = 2 To 8 Step 3
Row = 1
Do Until Row > row_i
If IsNumeric(Cells(Row, Col).Value) = False Then
Cells(Row, Col).Clear
Else
Cells(Row, Col).Select
If Cells(Row, Col).Value = 0 Then
Cells(Row, Col).Value = (Cells(Row, Col).Value) * 1
Cells(Row, Col).NumberFormat = "$ #,##0.00"
Else
Cells(Row, Col).Value = CDec((Cells(Row, Col).Value))
Cells(Row, Col).NumberFormat = "$ #,##0.00"
End If
End If
Row = Row + 1
Loop
Next
End Sub
I have no experience in Visual Basic and I am trying to add or delete columns based on a cell value while keeping the same format from the first column. I´ve seen some posts but my programming knowledge is very basic and I can´t find a way to adjust variables for it to fit into my file.
The following code seems to work for the post I read but as I said I don´t know what to change for it to work in my file:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, ColNum As Long, TotalCol As Long, LeftFixedCol As Long
Dim Rng As Range, c As Range
Set KeyCells = Range("B1")
If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
If IsNumeric(KeyCells.Value) = False Then Exit Sub
ColNum = KeyCells.Value
If ColNum <= 0 Then Exit Sub
Set Rng = Range(Cells(3, 1), Cells(3, Columns.Count))
Set c = Rng.Find("Total") 'the find is case senseticve, Change "Total" to desired key word to find
If c Is Nothing Then Exit Sub
TotalCol = c.Column
LeftFixedCol = 2 'Column A & B for Company and ID
Dim i As Integer
If TotalCol < LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol To LeftFixedCol + ColNum
Columns(i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
Next i
End If
If TotalCol > LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol - 1 To LeftFixedCol + ColNum + 1 Step -1
Columns(i).Delete
Next i
End If
End Sub
Is it too much to ask if somebody could please help identifying each code line or give me a more simple code to work with?
The following gif shows exactly what I am trying to do:
Thanks beforehand!
A Worksheet Change: Insert or Delete Columns
This code mustn't be copied into a standard module, e.g. Module1 as you did.
It needs to be copied into a sheet module, e.g. Sheet1, Sheet2, Sheet3 (the names not in parentheses), of the worksheet where you want this to be applied. Just double-click on the appropriate worksheet in the Project Explorer window (seen on the top-left of your screenshot), copy the code to the window that opens and exit the Visual Basic Editor.
The code runs automatically as you change the values in the target cell (B1 with this setup) i.e. you don't run anything.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
' e.g. to prevent
' "Run-time error '1004': Microsoft Excel can't insert new cells because
' it would push non-empty cells off the end of the worksheet.
' These non-empty cells might appear empty but have blank values,
' some formatting, or a formula. Delete enough rows or columns
' to make room for what you want to insert and then try again.",
' which is covered for the header row, as long there is nothing
' to the right of the total column, but not for other rows.
Const TargetCellAddress As String = "B1"
Const TotalFirstCellAddress As String = "D3"
Const TotalColumnTitle As String = "Total" ' case-insensitive
Dim TargetCell As Range
Set TargetCell = Intersect(Me.Range(TargetCellAddress), Target)
If TargetCell Is Nothing Then Exit Sub ' cell not contained in 'Target'
Dim NewTotalIndex As Variant: NewTotalIndex = TargetCell.Value
Dim isValid As Boolean ' referring to an integer greater than 0
If VarType(NewTotalIndex) = vbDouble Then ' is a number
If Int(NewTotalIndex) = NewTotalIndex Then ' is an integer
If NewTotalIndex > 0 Then ' is greater than 0
isValid = True
End If
End If
End If
If Not isValid Then Exit Sub
Dim hrrg As Range ' Header Row Range
Dim ColumnsDifference As Long
With Range(TotalFirstCellAddress)
Set hrrg = .Resize(, Me.Columns.Count - .Column + 1)
If NewTotalIndex > hrrg.Columns.Count Then Exit Sub ' too few columns
ColumnsDifference = .Column - 1
End With
Dim OldTotalIndex As Variant
OldTotalIndex = Application.Match(TotalColumnTitle, hrrg, 0)
If IsError(OldTotalIndex) Then Exit Sub ' total column title not found
Application.EnableEvents = False
Dim hAddress As String
Select Case OldTotalIndex
Case Is > NewTotalIndex ' delete columns
hrrg.Resize(, OldTotalIndex - NewTotalIndex).Offset(, NewTotalIndex _
- ColumnsDifference + 2).EntireColumn.Delete xlShiftToRight
Case Is < NewTotalIndex ' insert columns
With hrrg.Resize(, NewTotalIndex - OldTotalIndex) _
.Offset(, OldTotalIndex - 1)
' The above range becomes useless after inserting too many columns:
hAddress = .Address
.EntireColumn.Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
End With
With Me.Range(hAddress)
.Formula = "=""Column""&COLUMN()-" & ColumnsDifference - 1
.Value = .Value
End With
Case Else ' is equal; do nothing
End Select
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
I am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub
I,ve tried to find a VBA solution for finding the previous cell (located on the same row) with different value than the selected cell has. So if the selected cell is for example [N6] (as in my picture) then my search range should be ("A6:N6") from which I need to find the last cell with a different cell value (which would be cell [L6] in my picture because it's the previous cell with a different value than cell [N6]. The search should start from the end (N6,M6,L6...) backwards until the first match is found (first different cell value). When the first match is found then select it. I have hundreds of columns, so my picture is just to show the principle. I execute my vba code with Private Sub Worksheet_SelectionChange(ByVal Target As Range) so when the user selects a cell with the mouse. I get the desired cell with {=ADDRESS(6;MATCH(2;1/(A6:O6<>"D")))} but I would need a VBA solution for my problem. My current VBA solution takes me to cell [I6] instead of [L6] and I can't figure out how to edit my code to find the correct cell ([L6] in my example picture).
Dim rngSel As String, rngStart As String
Dim rngActiveStart As Range
rngSel = ActiveCell.Address(0, 0)
rngStart = Cells(ActiveCell.Row, 1).Address(0, 0)
Set rngActiveStart = Range(rngStart & ":" & rngSel)
Dim c
For Each c In rngActiveStart.Cells
If c <> Target.Value And c.Offset(0, 1) = Target.Value Then
c.Select
MsgBox "Previous different cell: " & c.Address(0, 0)
Exit For
End If
Next
Using selection_Change
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Long, col As Long, x
Dim v As String
r = Target.Row
v = Target.Value
Application.EnableEvents = False
For x = Target.Column To 1 Step -1
With Me
If .Cells(r, x) <> v Then
.Cells(r, x).Select
Exit For
End If
End With
Next x
Application.EnableEvents = True
End Sub
You need a For i = max To min Step -1 loop to loop backwards/left:
Public Sub MoveLeftUntilChange()
Dim SelRange As Range 'remember the selected range 'N6
Set SelRange = Selection
Dim iCol As Long
For iCol = SelRange.Column To 1 Step -1 'move columns leftwards
With SelRange.Parent.Cells(SelRange.Row, iCol) 'this is the current row/column to test againts the remembered range N6
If .Value <> SelRange.Value Then 'if change found select and exit
.Select
Exit For
End If
End With
Next iCol
End Sub
I am trying to copy rows onto three different sheets based on criteria in column AZ. I can get the first IF statement to work but the else ifs copy the information not in the first row of the designated sheet but where the previous sheet ended.
Here is what I have
Private Sub CommandButton1_Click()
Dim Cell As Range
With Sheets(2)
For Each Cell In .Range("AZ2:AZ" & .Cells(.Rows.Count, "AZ").End(xlUp).Row)
If Cell.Value = 1 Then
.Rows(Cell.Row).Copy Destination:=Sheets("2X4").Rows(Cell.Row)
ElseIf Cell.Value = 2 Then
.Rows(Cell.Row).Copy Destination:=Sheets("2X6").Rows(Cell.Row)
ElseIf Cell.Value = 3 Then
.Rows(Cell.Row).Copy Destination:=Sheets("2X6H").Rows(Cell.Row)
End If
Next Cell
End With
End Sub
Picking up on #Marcucciboy2's comment you could use something like this.
Private Sub CommandButton1_Click()
Dim Cell As Range, v1, v2
v1 = Array("2X4", "2X6", "2X6H"): v2 = Array(2, 2, 2)
With Sheets(2)
For Each Cell In .Range("AZ2:AZ" & .Cells(.Rows.Count, "AZ").End(xlUp).Row)
If Cell.Value = 1 Or Cell.Value = 2 Or Cell.Value = 3 Then
.Rows(Cell.Row).Copy Destination:=Sheets(v1(Cell.Value - 1)).Range("A" & v2(Cell.Value - 1))
v2(Cell.Value - 1) = v2(Cell.Value - 1) + 1
End If
Next Cell
End With
End Sub