I am creating simple hyperlink for a range of values as they are in text in original template. The hyperlink part is not working and also wondering the foreach case. I want the original text also to be seen as a hyperlink value in the cell. How do you do this in VBA?
Also how do you do the if statement if you want put it as the if contains pattern like "http://"?
The following does not work and I get errors.
Sub Convert_To_Hyperlinks()
Dim Cell As Range
Dim rng As Range
Dim ws1 As Worksheet
Set rng = Range("E5:E10")
Set ws1 = Sheets("Sheet1")
For Each Cell In rng
If Cell <> "" Then
ws1.Hyperlinks.Add Anchor:=ws1.Cell, Address:=ws1.Cell.Value, ScreenTip:="", TextToDisplay:=ws1.Cell
End If
Next Cell
End Sub
You can use the Like operator:
Sub Convert_To_Hyperlinks()
Dim ws1 As Worksheet, rng As Range, cell As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set rng = ws1.Range("E5:E10")
For Each cell In rng
If cell.Value Like "http://*" Then
ws1.Hyperlinks.Add Anchor:=cell, Address:=cell.Value, TextToDisplay:=cell.Value
End If
Next cell
End Sub
Related
I have a For Each Loop that looks for cells that contain a string with a wildcard and if that string is not bold. If those conditions are met then that cell's row is deleted. I believe the For Each Loop is inefficient, and even with only around 200 rows the code takes a few seconds to run. Is there a more efficient way to achieve these results?
Dim Cell As Range
Dim sheetRange As Range
Set sheetRange = ActiveSheet.UsedRange
For Each Cell In sheetRange
Set Cell = sheetRange.Find(What:="Total*", lookat:=xlPart)
If Not Cell Is Nothing Then
If Cell.Font.Bold = False Then
Cell.EntireRow.Delete
End If
End If
Next Cell
Please take a look at the code below and see if you can adapt it to your specific use case. The DeleteTotalRows subroutine uses the built-in .Find method to jump specifically to cells that include the value 'Total'. It passes each of these cells to the MergeDeleteRange subroutine. This sub will build a range to delete, which contains all rows with the Total word and bold font.
Report back if you run into issues.
Option Explicit
Sub DeleteTotalRows()
Dim fnd As Range
Dim rngToDelete As Range
Dim firstFnd As Range
Dim sht As Worksheet
'Update this
Set sht = Worksheets("Sheet2")
With sht
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart)
If fnd Is Nothing Then Exit Sub
Set firstFnd = fnd
Do
MergeDeleteRange rngToDelete, fnd
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart, after:=fnd)
Loop While fnd.Address <> firstFnd.Address
End With
If rngToDelete Is Nothing Then Exit Sub
rngToDelete.Delete
End Sub
Private Sub MergeDeleteRange(ByRef outputRng As Range, ByRef inputCell As Range)
'Not deleting if the cell isn't bold
If Not inputCell.Font.Bold Then Exit Sub
'Create output range if it's still empty
If outputRng Is Nothing Then Set outputRng = inputCell.EntireRow
'Since you are testing multiple columns, confirm that the
'row isn't already in the output range
If Not Intersect(inputCell, outputRng) Is Nothing Then
Exit Sub
End If
Set outputRng = Union(outputRng, inputCell.EntireRow)
End Sub
I have formulas throughout a workbook that are returning an output if matched with X and "" if not. I am new to VBA and macro's and unsure of where to begin. But my goal is to have a macro that I could run that clears the formula if it is blank or "" across multiples sheets. I would note, I only want it to do this in certain columns of each sheet.
Example:
Sheet 1 has the formula in cells H10:K20, while Sheet 2 has the formula in AV8:AV400, etc. etc. The goal being to have it recognize "Sheet 1" is a range of H10:K20 where it would erase, Sheet 2 is AV8:AV400.
Any help would be greatly appreciated!
I had found another question that was kind of similar, but I could not figure out how to make it recognize different sheet names or specific ranges within my file. I have pasted the code I had found and tried to use below as well as the link here.
How to clear cell if formula returns blank value?
Sub ClearCell()
Dim Rng As Range
Set Rng = ActiveSheet.Range("A1")
Dim i As Long
For i = 1 To 10
If Rng.Cells(i,1) = "" Then
Rng.Cells(i,1).ClearContents
End If
Next i
End Sub
Maybe something very basic:
Sub ClearEmptyFormulas()
Dim ws As Worksheet
Dim rng As Range, cl As Range
For Each ws In ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) 'Extend the array or loop all worksheets
Select Case ws.Name
Case "Sheet1"
Set rng = ws.Range("H10:K20")
Case "Sheet2"
Set rng = ws.Range("AV8:AV400")
'Etc
End Select
For Each cl In rng
If cl.Value = "" Then
cl.ClearContents
End If
Next cl
Next ws
End Sub
Or even a bit simpler:
Sub ClearEmptyFormulas()
Dim rng As Range, cl As Range
Dim arr1 As Variant: arr1 = Array("Sheet1", "Sheet2")
Dim arr2 As Variant: arr2 = Array("H10:K20", "AV8:AV400")
For x = 0 To 1
Set rng = Sheets(arr1(x)).Range(arr2(x))
For Each cl In rng
If cl.Value = "" Then
cl.ClearContents
End If
Next cl
Next x
End Sub
I have 2 sheets, 'Initial' & 'Report1'. I'm trying to copy specific rows from 'Inital' to 'Report1' when the cell in column 'H' is = "On going".
I have the function as a button in excel but cant workout how to copy and paste the line and move onto the next cell.
Also, Column D is formula and needs to be pasted special to copy over.
I have attached the current code I have tried but it errors. Any help would be greatly appreciated.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital")
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Inti").Range("H5:H9999")
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
Sheets("Inti").Range("").End(xlDown).Select
ActiveSheet.Paste
End If
Next cell
End Sub
I expect the all rows in column 'H' that = "On Going" to be copied to "Report1".
I think this does what you want. You might want to improve the range you're looping through in case you only have, e.g. 100 cells of data.
A quicker approach than looping would be AutoFilter.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital") 'check name - typo?
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Inti.Range("H5:H9999") 'already defined worksheet so just use variable
'Set rngA = Inti.Range("H5",inti.range("H" & rows.count).end(xlup)) 'would be more efficient
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
repl.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues 'copy to the other sheet
End If
Next cell
End Sub
I want to get a list of distinct value based on a criteria, example : I have a list of stores, and i want to get only distinct value based on retailer criteria "BOULANGER".
Sub distinctValues()
Dim LastRow As Long
Dim Crit1 As String
LastRow = Sheets("SOURCE").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("SOURCE").Range("B1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("TEST").Range("E2"), CopyToRange:=Sheets("TEST").Range("A12"), Unique:=True
End Sub
I suspect your Criteria Range is not properly set up and/or named on your worksheet.
In the .AdvancedFilter, you have:
Range(Crit1)
which, according to your code, will be interpreted as:
Range("BOULANGER")
This presumes you have a Named Range somewhere on your Test Worksheet that is named BOULANGER and refers to two cells in a column, the first of which contains Store and the second contains BOULANGER
If you have that set up properly, then your code works.
Note that in your screen shot showing the criteria, the first cell contains Criteria and not Store. So even if you had the defined range setup to encompass those two cells, it would not work since the first row has to have an identical name to the column being filtered.
This should accomplish what you are trying to do; see comments in the code.
Sub ListUniqueValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'change as needed
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'change as needed
ws1.Range("B1", ws1.Cells(Rows.Count, "B").End(xlUp)).Copy ws2.Range("C1") 'copy the full range from sheet1
ws2.Range("C1", ws2.Cells(Rows.Count, "C").End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo 'remove duplicates
Dim lRow As Long
lRow = ws2.Cells(Rows.Count, 3).End(xlUp).Row 'set lastrow variable
For i = lRow To 1 Step -1 'Da Loop, from bottom to top
'change the cell address after "Like" to the cell address where you put your store criteria
'the line will delete any store name that is not like your store criteria
'the (& "*") inserts the wildcard after your store criteria you type in your designated cell, e.g. "BOULANGER*"
If Not ws2.Cells(i, 3).Value Like ws2.Cells(1, 1).Value & "*" Then '
ws2.Cells(i, 3).Delete 'delete the cells that do not match your store criteria
End If
Next i
End Sub
If you are trying to get a unique range that contains a keyword, something like this should work.
Option Explicit
Private Sub OutputUniqueRange(SearchRange As Range, Keyword As String, OutputRange As Range)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In SearchRange
With cell
If InStr(1, .Value2, Keyword, vbTextCompare) > 0 And Not dict.exists(.Value2) Then dict.Add .Value2, .Value2
End With
Next
If dict.Count = 0 Then Exit Sub
OutputRange.Range(OutputRange.Cells(1, 1).Address).Resize(dict.Count, 1) = Application.Transpose(dict.items())
End Sub
Public Sub TestSub()
Dim SearchRange As Range
Dim Keyword As String
Dim OutputRange As Range
Keyword = "Boulanger"
Set SearchRange = ThisWorkbook.Sheets("Sheet1").Range("A2:A34")
Set OutputRange = ThisWorkbook.Sheets("Sheet1").Range("B2")
OutputUniqueRange SearchRange, Keyword, OutputRange
End Sub
I'm using excel VBA and I'm trying to increment a Range selection in a loop.
Sub sorter()
Dim i As Integer
Dim copyLoc As String = "E1"
For i = 0 To 5
Range(copyLoc).Select '//what type is Range() supposed to take?
Selection.Copy
copyLoc = ActiveCell.Offset(0, 6) '//what type does ActiveCell.Offset return?
Next i
End Sub
I'm sure the problem is with the data type that ActiveCell.Offset is returning. Can anyone tell me what I should use instead? Thanks kindly!
Expanding on my comment above. "Range" is an object type. So you want to dim your variable as a "Range" not a string:
Sub sorter()
Dim i As Integer
Dim copyLoc As Range
Set copyloc = Range("E1")
For i = 0 To 5
'copy from copyloc and stick it in a cell offset 6 columns to the right
copyLoc.Copy Destination:=copyLoc.Offset(0,6)
'Increment to the next row?
Set copyLoc = copyLoc.Offset(1)
Next i
End Sub
I'm just guessing here at what you are trying to accomplish, but either way I think this will get you in the ballpark. If you are incrementing through 6 rows starting at E1 you could also use something like:
Sub sorter()
Dim rngRow as Range
Dim copyRange as Range
Set copyRange = Range("E1:E6")
'Loop through each row in the range's "Rows" collection
For each rngRow in copyRange.Rows
'Copy the value from the "E" column to the "K" column in this row
rngRow.Cells(1,11).value = rngRow.cells(1,5).value
Next rngRow
End Sub
Being able to loop/iterate through each item in a collection, and understanding that most objects in VBA are part of a collection is hugely powerful.
For instance, looping through all of the sheets in the ThisWorkbook.Worksheets collection:
Dim ws as worksheet
For each ws in ThisWorkbook.Sheets
'print the name of the worksheet to the "immediate" pane
debug.print ws.name
Next ws
Or looping through all cells in a range's "Cells" collection:
Dim rngCell as Range
For each rngCell in Range("A1:C50").cells
'do something to the cell
Next rngCell