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
Related
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
The code below searches for duplicates in different sheets of my work book. The issue is that it takes a little while for it to be done. How can I add a progress indicator in the status bar at the bottom?
Thank you & Kind regards.
Sub dup()
Dim cell As Range
Dim cella As Range
Dim rng As Range
Dim srng As Range
Dim rng2 As Range
Dim SheetName As Variant
Application.ScreenUpdating = False
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set srng = Sheets("Screener").Range("A7:A2000")
Set rng = Sheets("Rejected").Range("A7:A2000")
Set rng2 = Sheets("Full Data").Range("A7:A2000")
For Each cell In rng
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 4
cella.Offset(, 1) = "Rejected"
End If
Next cella
Next cell
For Each cell In rng2
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 5.5
cella.Offset(, 1) = "Reported"
End If
Next cella
Next cell
Application.ScreenUpdating = True
End Sub
One thing you can do is speed up your code, there's a few things I'd change about it in its current state,
It's really slow to access range objects and their value, you should instead load the ranges into a variant array and cycle through the arrays
If you find a duplicate, you still go through and check every other range in both arrays which wastes time, you should skip to the next range once you've found a duplicate
With that in mind I've rewritten your code like this, it's completely equivalent and runs in less than a second on my machine:
Sub dup()
Dim i As Integer, j As Integer
Dim RejectVals As Variant
Dim ScreenVals As Variant
Dim FullDataVals As Variant
Dim SheetName As Variant
Dim output() As String
'Push column on 'Screener' sheet to the right to make space for new output
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Worksheets("Screener").Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Pull the values from your 3 ranges into arrays to avoid costly cycling through ranges
ScreenVals = Application.Transpose(Sheets("Screener").Range("A7:A2000").Value)
RejectVals = Application.Transpose(Sheets("Rejected").Range("A7:A2000").Value)
FullDataVals = Application.Transpose(Sheets("Full Data").Range("A7:A2000").Value)
'Resize output column to be same size as column we're screening because
'we're going to place it in the column adjacent
ReDim output(LBound(ScreenVals) To UBound(ScreenVals))
'Cycle through each value in the array we're screening
For i = LBound(ScreenVals) To UBound(ScreenVals)
'Skip without checking if the cell is blank
If ScreenVals(i) = vbNullString Then GoTo rejected
'Cycle through each value in the 'FullData' array
For j = LBound(FullDataVals) To UBound(FullDataVals)
'If it's a duplicate then
If ScreenVals(i) = FullDataVals(j) Then
'Set the relevant value in the output array to 'Reported'
output(i) = "Reported"
'Colour the cell on the 'screener' page
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 5.5
'Skip checking more values
GoTo rejected
End If
Next j
'Next cycle through all the 'Rejected' values
For j = LBound(RejectVals) To UBound(RejectVals)
'If it's a duplicate then
If ScreenVals(i) = RejectVals(j) Then
'Set the relevant value in the output array to 'Rejected'
output(i) = "Rejected"
'Colour the cell
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 4
'Skip checking any more values
GoTo rejected
End If
Next j
rejected:
Next i
'Pop the output array in the column next to the screened range
Worksheets("Screener").Range("B7:B2000") = Application.Transpose(output)
End Sub
I check for duplicates in the 'Full Data' sheet first which means if there is a duplicate in both tables then it will default to 'Reported' and a yellow cell, if you'd like the opposite you can swap the order of the loops.
Let me know if there's anything you don't understand
Sorry I am a novice in VBA so any help is gratefully received!
I'm looking for some VBA code for a loop that will look at a range in Column A and as long as the cell in Column A is not 0, replace the adjacent cell in Column B with the positive value, looping through the range until all cells with data > 0 in Column A have been replaced in Column B. It is also important that blank cells in Column A do not overwrite positive data that may exist in Column B.
This is where I am at the moment:
Sub Verify()
Dim rng As Range
Dim i As Long
'Set the range in column N
Set rng = Range("N2:n1000")
For Each cell In rng
'test if cell = 0
If cell.Value <> 0 Then
'write value to adjacent cell
cell.Offset(0, -2).Value = *'What do I need here to find the first item of data e.g. N2 in column N?'*
End If
Next
End Sub
Many thanks
I think it would be easier to deal with ActiveSheet.Cells as with Range object and offsets :
Sub Verify()
Dim row As Long
For row = 2 To 1000
If ActiveSheet.Cells(row,1) <> "" Then ' Not blank
If ActiveSheet.Cells(row,1) > 0 Then ' Positive
ActiveSheet.Cells(row,2) = ActiveSheet.Cells(row,1)
End If
End If
Next
End Sub
This is the edit to what you started. I made the range dynamic, because I don't like making excel loop longer than it has to. That's my personal preference. The first block of code will copy over anything that isn't 0 or blank, and any negative numbers will be represented by their positive counterpart. That's at least how I understood your question.
Also, this code looks at data in Col N (like you have in your code) and copies the data to Col L. If you want A to B then simply change rng to = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp)) and the myCell.Offset() to (0, 1).
Sub Verify()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets(1) 'good form to always define the sheet you're working on
Set rng = ws.Range("N2", ws.Cells(ws.Rows.Count, "N").End(xlUp)) 'dynamic range
For Each myCell In rng
If myCell.Value <> "" And myCell.Value <> 0 Then 'If the cell isn't 0 or ""
If myCell.Value < 0 Then 'Then if it's negative, make it positive and copy it over
myCell.Offset(0, -2).Value = myCell.Value * -1
Else: myCell.Offset(0, -2).Value = myCell.Value 'otherwise copy the value over
End If
End If
Next myCell
End Sub
If you only want to copy over values that are greater than 0, and ignore 0's, blanks, and negative values, then use this code:
Sub Verify()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets(1) 'good form to always define the sheet you're working on
Set rng = ws.Range("N2", ws.Cells(ws.Rows.Count, "N").End(xlUp)) 'dynamic range
For Each myCell In rng
If myCell.Value <> "" And myCell.Value > 0 Then 'If the cell is > 0 and not ""
myCell.Offset(0, -2).Value = myCell.Value 'copy the value over
End If
Next myCell
End Sub
If I understand your question correctly, you can "simplify" it to something like this:
Sub Verify()
[b2:b1000] = [if(iferror(-a2:a1000,),abs(a2:a1000),b2:b1000&"")]
End Sub
just replace a2:a1000 with your Column A range and b2:b1000 with the Column B range.
I want to unhide a single row if an ENTIRE range of rows is hidden. I want to hide this row if even a SINGLE row within the range is unhidden. What is the syntax for this? My current code is as follows:
Public Sub MySub()
Application.ScreenUpdating = False
With Range("A1:A5")
.EntireRow.Hidden = False
For Each cell In Range("A1:A5")
Select Case cell.Value
Case Is = "-"
cell.EntireRow.Hidden = True
End Select
Next cell
End With
Application.ScreenUpdating = True
End Sub
I think I understand. How's this:
Sub test()
Dim cel As Range, rng As Range
Dim hideRow&, numDashes&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
For Each cel In rng
If cel.Value = "-" Then
numDashes = numDashes + 1
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
If numDashes = rng.Count Then
' If all cells in the range are '-'
Rows(hideRow).EntireRow.Hidden = False
Else
Rows(hideRow).EntireRow.Hidden = True
End If
End Sub
I'm kind of assuming that you want to hide/unhide Row 6, since it's one below your range's last row. Therefore, I created a variable to hold this. This way, if you want to change your range to say A1:A100, all you have to do is adjust the rng, and it'll look to hide/unhide row 101. Of course, if you just need it to be 6, then just do hideRow = 6.
Edit: For fun, I tried to reduce the use of the counting variable numDashes and tried to the part where you check your range for all - to be more concise. The below should work too, but might need a tweak or two:
Sub test2()
Dim cel As Range, rng As Range
Dim hideRow&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
'Check to see if your range is entirely made up of `-`
If WorksheetFunction.CountIf(rng, "-") = rng.Count Then
Rows(hideRow).EntireRow.Hidden = False
' If you want to stop your macro if ALL range values are "-", then uncomment the next line:
'Exit Sub
Else
Rows(hideRow).EntireRow.Hidden = True
End If
For Each cel In rng
If cel.Value = "-" Then
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
End Sub
You can do this with a formula in a helper column. I used this one for financial statements to suppress rows where multiple column are all zero to shorten up the report.
=IF(AND(SUM(A7:R7)<1,SUM(A7:R7)>-1),IF(OR(ISNUMBER(LEFT(H7,4)),ISBLANK(H7),ISERR(VALUE(LEFT(H7,4)))),"Show","Hide"),"Show").
Then filter the rows by that column.