I am setting up a loop and i don't know what code to put in.
Below the code runs but at the end all the cells that have had a hyperlink inserted show cell 173 when there should be a link to cell 32 in the first cell then cell 47 in second and so on. I can see the problem but not sure on what to do.
Sub Hyperlink()
Dim rng As Range
Dim cell As Range
Dim t1 As ListObject
Set t1 = Range("Testtbl").ListObject
Dim i As Integer
Dim p As String
Set rng = Range("CourseName")
For Each cell In rng
For i = 1 To t1.ListRows.Count
If t1.ListColumns("UnLockedField").DataBodyRange(i) = "H" Then
p = t1.ListColumns("UnLockedField").DataBodyRange(i).Address
With cell
.Hyperlinks.Add Anchor:=cell, _
Address:="", _
SubAddress:=p
End With
End If
Next i
Next cell
End If
0:
End Sub
I am hoping that each cell in the range will have its on link to the cell that i needs to go to.
Related
I am trying to write some VBA in excel that will clear all cells starting from the next empty cell in Column A (data starts from A2). For example, if A5 is blank then I want A5:P300 to all be cleared (as in all Formula and Data gone). And so on... so if A20 is blank then it deletes everything from A20:P300..
How would I go about writing this? I also need it to refer to the active workbook but a specific worksheet called ("Develop").
Thanks for any help provided.
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("R&DCosts(2)")
Set rng = x.Range("A2:A340").Cells(Rows.Count, 1).End(xlUp)
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Try this code, please:
Sub clearRange_Bis()
Dim sh As Worksheet, firstEmpt As Long
Set sh = ThisWorkbook.Worksheets("R&DCosts(2)")
firstEmpt = sh.Range("A1").End(xlDown).Row + 1
If firstEmpt > 1000000 Then
sh.Range("A2:P300").Clear
Else
sh.Range("A" & firstEmpt & ":P300").Clear
End If
End Sub
A more simple solution
Option Explicit
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("RDCosts(2)") ' you cannot use "&"
Set rng = x.Range("A2:A340", Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
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
Does anyone know what other command I need to use to copy the row label "Total WI Expenses" down 4 rows below?
The following code will find the "Total WI Expenses" and copy it to a range, however, I just want to find the total and copy the data to the 4 rows down. They need to be copied and pasted as values.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rw As Long, Cell As Range
For Each Cell In ActiveSheet.Range("B:B")
If Cell.Value = "Total WI Expenses" Then
Cell.EntireRow.copy
Range("A71").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next
End Sub
I sincerely appreciate your assistance.
Instead of running a For loop over the whole(!) column you may check first, if something is in the column, and then .Find the wanted value. If you found a result, then you may use it's row number.
Instead of Copy/Paste you may just assign the Range.Value to get the values without formatting.
This code copies the whole row's values four rows below.
Sub Test()
Dim ws As Worksheet
Dim c As Range
Set ws = ActiveSheet
If WorksheetFunction.CountA(ws.Columns(2)) > 0 Then
Set c = ws.Columns(2).Find( _
What:="Total WI Expenses", _
After:=ws.Cells(1, 2), _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not c Is Nothing Then
ws.Rows(c.Row + 4).Value = ws.Rows(c.Row).Value
End If
Set c = Nothing
End If
Set ws = Nothing
End Sub
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub
I have a list of true and false values on sheet 3 column A and a list of codes on sheet 2 Column A. If the value on sheet 3 A5 is = True then I want the value on sheet 2 A5 should be colored red. And If the value on sheet 3 A6 is = True then I want the value on sheet 2 A6 should be colored red. And this should move down along Column A on sheet 2 and sheet 3 until data runs out. So far i have got it to work for the first cell in column A but can not get the For Each loop to work. Any Help would be greatly appreciated.
Sub compare_cols()
Dim myRng As Range
Dim lastCell As Long
'Get the last row
Dim lastRow As Integer
lastRow = ActiveSheet.UsedRange.Rows.Count
'Debug.Print "Last Row is " & lastRow
Dim c As Range
Dim d As Range
Set c = Worksheets("Sheet3").Range("A5:25")
Set d = Worksheets("Sheet2").Range("A5:25")
Application.ScreenUpdating = False
For Each cell In c
For Each cell In d
If c.Value = True Then
d.Interior.Color = vbRed
End If
Next
Next
Application.ScreenUpdating = True
End Sub
A more efficient solution wouldn't necessarily next 2 loops within each other. Instead, loop through the range that you'd like to check, and reference the cells Address property to identify new cells to highlight.
Check the code below and let me know if you understand it
Sub ColorOtherSheet()
Dim wsCheck As Worksheet
Dim wsColor As Worksheet
Dim rngLoop As Range
Dim rngCell As Range
Set wsCheck = Worksheets("Sheet3")
Set wsColor = Worksheets("Sheet2")
Set rngLoop = Intersect(wsCheck.UsedRange, wsCheck.Columns(1))
For Each rngCell In rngLoop
If rngCell.Value = True Then
wsColor.Range(rngCell.Address).Interior.Color = vbRed
End If
Next rngCell
End Sub