How to apply a condition to "used range" in whole column as a loop in excel using VBA? - excel

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

Related

Insert/Delete columns based on a cell value

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

Compare All Cells in 2 Worksheets

I need to be able to compare every cell in 2 worksheets but the data won't always be in the same row as new data is added and exported constantly.
Range on both sheets would be fairly large, so for now I have limited it to A1:AS150. Any instance where a match cannot be found I'd like to highlight the cell.
I have found this, which looks close to what I need but doesn't work (obviously, I have added the Else code in my working example).
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
strRangeToCheck = "A1:AS150"
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
' Cells are different.
' Code goes here for whatever it is you want to do.
End If
Next iCol
Next iRow
To answer 'Foxfire And Burns And Burns' Questions:
Checks: Does Sheet1.Cell$.Value exist in sheet2 but for every cell in the range on both sheets.
Sheet1
A
B
C
Paul
999
ABC111
John
888
ABC222
Harry
777
ABC333
Tom
666
ABC444
Sheet2
A
B
C
Tom
666
ABC444
John
888
ABC222
Harry
777
ABC333
So in these examples:
Search Sheet1.A1 in Sheet 2, IF = Match Then nothing ELSE Highlight Red. Then A2, A3 etc, Then B1, B2 etc, Then C1, C2 etc...you get the gist.
You mention in your VBA code that something will need to be done, but in your example your just mean that a cell will be highlighted.
This is already covered by Excel's conditional formatting feature. You can be conditional formatting on a formula (in your case you might use a Match() function).
I would advise you to start working with a =Match() formula, in order to learn how this works (you might use =MATCH(A1,$B$1:$B$2,0) as an example, the dollarsigns are used for indicating that the lookup values are not to change), do it on different sheets and then try to get conditional formatting working, first basically and then based on your formula.
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("A:A"), varSheetA.Range("A" & i).Value) = 0 Then varSheetA.Range("A" & i).Interior.Color = vbRed
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
The code will count each single cell value from column A from Sheet 1 and will check if it exists somewhere in column A in Sheet 2. If not, then highligh in red.
Output after executing code with the data example you've posted:
UPDATE": I made a fakedataset. Notice row Captain America. Values from columns A and C are same in both sheets, but different on column B
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Dim MyPos As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("C:C"), varSheetA.Range("C" & i).Value) > 0 Then
'Match found on Column C. Check A and B
MyPos = Application.WorksheetFunction.Match(varSheetA.Range("C" & i).Value, varSheetB.Range("C:C"), 0)
If varSheetA.Range("A" & i).Value <> varSheetB.Range("A" & MyPost.Value Then varSheetA.Range("A" & i).Interior.Color = vbRed
If varSheetA.Range("B" & i).Value <> varSheetB.Range("B" & MyPos).Value Then varSheetA.Range("B" & i).Interior.Color = vbRed
End If
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
Output:
That cell has been highlighet because is different.
Please, note this code will work only if all values in column C are unique.
Here is my code:
Option Explicit
Private Const SHEET_1 As String = "Sheet1"
Private Const SHEET_2 As String = "Sheet2"
Private Const FIRST_CELL As String = "A1"
Private Const MAX_ROWS As Long = 1048576
Private Const MAX_COLUMNS As Long = 16384
Private varSheetA As Worksheet
Private varSheetB As Worksheet
Private last_row As Long
Private last_column As Long
Private sheet1_row As Long
Private sheet1_column As Long
Private sheet2_row As Long
Private row_match As Boolean
Public Sub CompareTables()
Set varSheetA = ThisWorkbook.Worksheets(SHEET_1)
Set varSheetB = ThisWorkbook.Worksheets(SHEET_2)
'Gets the real Table size
For sheet1_row = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString Then
last_row = sheet1_row
Exit For
End If
Next
For sheet1_column = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString Then
last_column = sheet1_column
Exit For
End If
Next
'Sets color RED by default on both Tables
Call SetTextRed(varSheetA.Range(FIRST_CELL).Resize(last_row, last_column))
Call SetTextRed(varSheetB.Range(FIRST_CELL).Resize(last_row, last_column))
'Sweeps all existing ROWS on Sheet1
For sheet1_row = 1 To last_row
'Sweeps all existing ROWS on Sheet2
For sheet2_row = 1 To last_row
row_match = True
'Sweeps all existing COLUMNS on Sheet1 and Sheet2
For sheet1_column = 1 To last_column
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, sheet1_column - 1).Value _
<> varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, sheet1_column - 1).Value Then
row_match = False
Exit For
End If
Next
If row_match Then Exit For 'Found and entire match, no need to search more
Next
'Formats as Grren whenever is a Match
If row_match Then
Call SetTextGreen(varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, 0).Resize(1, last_column))
Call SetTextGreen(varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, 0).Resize(1, last_column))
End If
Next
End Sub
'Sub Function that sets entire row text as RED
Private Sub SetTextRed(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(255, 0, 0)
.TintAndShade = 0
End With
End Sub
'Sub Function that sets entire row text as GREEN
Private Sub SetTextGreen(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(0, 255, 0)
.TintAndShade = 0
End With
End Sub

Find previous cell address (to the left) in active row with different value than active cell value

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

VBA Excel - deleting rows at specific intervals

I am new to this forum, so bear with me.
I have a CSV-file that I need to apply some VBA-modules to in order to get the information I need.
In short, I have 3 macros that together to the following:
Create a new row every 20th row
Take the number from the cell above (column A) and fill the blank space in the new row with this number.
Sum the numbers in column H from the 20 rows before the new row to get a total score. This is done subsequently for as long as new rows appear (every 20th row).
Is it possible to get these three macros in a single macro? This would make it easier to hand down to others that may need to use these macros.
Current code:
' Step 1
Sub Insert20_v2()
Dim rng As Range
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
End Sub
' Step 2
Sub FillBlanks()
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
' Step 3
Sub AutoSum()
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
End Sub
Thank you for any help.
Best,
Helge
You can create a single Sub calling all the other subs that you have created.
Example:
Sub DoAllTasks()
Insert20_v2
FillBlanks
AutoSum
End Sub
Then you just have to create a button and assign the DoAllTasks to it or run the macro directly.
HTH ;)
That Should'nt be that hard.
Public Sub main()
'deklaration
Dim rng As Range
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
'Loop trough all Rows
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
'Fill the Blank Rows in A
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
End Sub

Select a hyperlink in one column based on "X" in adjacent column

So I'm fairly new to VBA, and I have been struggling with trying to get my macro to work.
Essentially what I'm trying to do is have a program read down a column, and for every "X" located in that column, the corresponding hyperlink in the adjacent column will be selected.
Sub Select_Hyperlinks()
Dim rng As Range, cell As Range, sel As Range
Dim sht As Worksheet
For x = 1 To 6
Set sht = Sheets("Generator")
Set sel = cell.Offset(-1, 0)
Set rng = Intersect(sht.Range("D4:D9"), sht.UsedRange)
For Each cell In rng.Cells
If (cell.Value) <> "X" _
Then
If sel Is Nothing Then
Set sel = cell.Offset(-1, 0)
sel.Select
End If
Next cell
End If
Next x
End Sub
I also tried a simpler idea using the Find and FindNext functions and for each X, I tried to get it to select and activate the cell in the adjacent column, but also with no luck. It seems I always get snagged up on the .Offset function.
EDIT:
Here's what I've managed to come up with, after some further research. I've adapted this from a macro designed to delete all empty rows.
Sub AutoOpen()
Dim xlastcell As Integer
Dim xcell As Integer
xcell = 1
Range("C200").End(xlUp).Select
xlastcell = ActiveCell.Cells 'This used to say ActiveCell.Row but I want a single cell'
Do Until xcell = xlastcell
If Cells(xcell, 1).Value = "X" Then
Cells(x, 1).Select
ActiveCell.Offset(0, -1).Select 'I'm also unable to get this function to work'
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
xcell = xcell - 1
xlastcell = xlastcell - 1
End If
xcell = xcell + 1
Loop
End Sub
Are you saying that if there is an X in the one column, you want to open the hyperlink?
EDIT:
Use this and change things to match your variables.
Sub asdhkl()
Dim c As Hyperlink
Dim i As Range
For Each i In Sheets(1).Range("b1:b3")
If i = "x" Then
Set c = i.Offset(0, -1).Hyperlinks(1)
c.Follow
End If
Next i
End Sub

Resources