I'm trying to get my code to search column D for cells that are not blank. When it finds one that isn't blank it copies that cell and fills the series beneath. Then I want it to repeat this code until "D3020".
However each time I run my code it takes the copied cell and continuously pastes it all the way down to "D3020". There are different values that also need to be copied so I need to fix this. I have tried using the .offset property. I have tried using .range.copy property.
Sub Fill()
Dim SRng As Range
Dim SCell As Range
Set SRng = Range("D1101:D3020")
For Each SCell In SRng
If SCell <> "" Then
SCell.Copy
Range(SCell, SCell.Offset(10, 0)).PasteSpecial(xlPasteAll)
End If
Next SCell
End Sub
I'd like this code to search Range("D1101:D3020") for cells that <> "". When one is found, fill the series beneath it, stopping at the next cell with a number in it.
For example
D1101 = 1601166 (see picture) I want to copy this and fill the series beneath it. All are exactly ten rows apart. Then D1121 = 1601168 (see picture) I want to copy/fill series for this as well.
No need for a loop; just fill the blanks with the value above.
sub fillBlanks()
dim brng as range
on error resume next
set brng = Range("D1101:D3020").specialcells(xlcelltypeblanks)
on error goto 0
if not brng is nothing then
brng.formular1c1 = "=r[-1]c"
Range("D1101:D3020") = Range("D1101:D3020").value
end if
end sub
Option Explicit
Sub Test()
FillEmptyFromTop [D1101:D3020]
End Sub
Sub FillEmptyFromTop(oRng As Range)
Dim v, a, i
With oRng.Columns(1)
a = .Value
For i = LBound(a, 1) To UBound(a, 1)
If IsEmpty(a(i, 1)) Then a(i, 1) = v Else v = a(i, 1)
Next
.Value = a
End With
End Sub
Related
Given that I am told we should be using Centered Across Selection instead of Merged Cells, I need to get the underlying value that is displayed across the cells when formatted as Centered Across Selection.
When using Merged Cells, it was easy:
CellValue = rng.MergeArea.Cells(1, 1).Value
Is there an easy way to get the same for Centered Across Selection, other than searching backwards while HorizontalAlignment = xlHAlignCenterAcrossSelection until the Cell Value <> "". My code to do this would be:
Function GetCenteredAcrossSelectionCellValue(rng As Range) As Variant
Dim i As Long
Dim l As Long
Dim ws As Worksheet
Set ws = rng.Worksheet
i = rng.Column
r = rng.Row
If rng.HorizontalAlignment = xlHAlignCenterAcrossSelection Then
Do Until (ws.Cells(r, i).Value <> "" And rng.HorizontalAlignment = xlHAlignCenterAcrossSelection)
i = i - 1
Loop
End If
GetCenteredAcrossSelectionCellValue = ws.Cells(r, i).Value
End Function
However, I don't this this is foolproof, because it could be possible that someone applied Center Across Selection to a single cell (say A1 for example) with a value, and then applied Center Across Selection to 3 empty cells (B1:D1). When asked for the "value" for D1, the above code would return the value in A1.
Excel must know because it formats correctly, so is there an easy way to tell in VBA, similar to the way we can tell for Merged Cells?
Following on from the comment above...
Apply "center across selection" to A1:J1 then run tester with values in different cells in that range and compare the outputs.
Sub tester()
Dim c As Range, rng As Range
For Each c In Range("A1:J1")
Set rng = CenteredRange(c)
If Not rng Is Nothing Then
Debug.Print c.Address, rng.Address
Else
Debug.Print c.Address, "not centered"
End If
Next c
End Sub
'return the current "center across" range given a starting point
Function CenteredRange(c As Range) As Range
Dim cStart As Range, cEnd As Range, cNext As Range
Set c = c.Cells(1) 'make sure we're dealing with a single cell
If Not c.HorizontalAlignment = xlCenterAcrossSelection Then Exit Function
Set cStart = c.Parent.Range(c.Address)
Set cEnd = c.Parent.Range(c.Address)
'look for the beginning
Do While cStart.Column > 1 And cStart.HorizontalAlignment = xlCenterAcrossSelection
If Len(cStart.Value) > 0 Then Exit Do 'stop if find a value
Set cStart = cStart.Offset(0, -1)
Loop
'look for the end
Do While cEnd.Column < Columns.Count - 1 And cEnd.HorizontalAlignment = xlCenterAcrossSelection
Set cNext = cEnd.Offset(0, 1) 'checking the next cell...
If Len(cNext.Value) > 0 Or cNext.HorizontalAlignment <> xlCenterAcrossSelection Then Exit Do
Set cEnd = cEnd.Offset(0, 1)
Loop
Set CenteredRange = c.Parent.Range(cStart, cEnd)
End Function
I have a worksheet with 3 rows and 7 columns (A1:G3).
A and B columns have 6 checkboxes (A1:B3). Boxes in columns A & B are linked to columns C & D respectively. Cells in columns E & F are just replicating columns C & D respectively (live E1 cell is =C1 and F3 cell is =D3).
I want to put a timestamp in cell G for each row when a checkbox is ticked or unticked by using Worksheet_Calculate event in VBA for that sheet.
My code works when used for just 1 row.
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
End Sub
I want to combine the code for 3 rows.
Here are 2 variations:
1st one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
Set cbX2 = Range("A2:F2")
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
ElseIf Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
ElseIf Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them with ElseIf like in the code above, a timestamp gets put in only G1, no matter if I tick B1 or C2.
2nd one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
Set cbX2 = Range("A2:F2")
If Not Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
End If
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them by ending each one with End If and start a new If, timestamp gets put in all of the G1, G2 and G3 cells, even if I tick just one of the boxes.
You seem to be confusing Worksheet_Calculate with Worksheet_Change and using Intersect as if one of the arguments was Target (which Worksheet_Calculate does not have).
Intersect(cbX1, Range("A1:F1")) is always not nothing because you are comparing six apples to the same six apples. You might as well ask 'Is 1,2,3,4,5,6 the same as 1,2,3,4,5,6?'.
You need a method of recording the values of your range of formulas from one calculation cycle to the next. Some use a public variable declared outside the Worksheet_calculate sub procedure; personally I prefer a Static variant array declared within the Worksheet_calculate sub.
The problem with these is initial values but this can be accomplished since workbooks undergo a calculation cycle when opened. However, it is not going to register Now in column G the first time you run through a calculation cycle; you already have the workbook open when you paste in the code and it needs one calculation cycle to 'seed' the array containing the previous calculation cycle's values.
Option Explicit
Private Sub Worksheet_Calculate()
Static vals As Variant
If IsEmpty(vals) Then 'could also be IsArray(vals)
vals = Range(Cells(1, "A"), Cells(3, "F")).Value2
Else
Dim i As Long, j As Long
With Range(Cells(1, "A"), Cells(3, "F"))
For i = LBound(vals, 1) To UBound(vals, 1)
For j = LBound(vals, 2) To UBound(vals, 2)
If .Cells(i, j).Value2 <> vals(i, j) Then
Application.EnableEvents = False
.Cells(i, "G") = Now
Application.EnableEvents = True
vals(i, j) = .Cells(i, j).Value2
End If
Next j
Next i
End With
End If
End Sub
I have a list of links in more than 100000 cells.
I have to give hyperlinks to all of them but in Excel there is a limit of 65530 hyperlinks per worksheet.
How can I overcome the limit or how can I merge cells with equal values using VBA?
Sub AddHyperlinks()
Dim myRange As Range
Set myRange = Range("A1")
Dim hText As Variant
Do Until IsEmpty(myRange)
hText = Application.VLookup(myRange.Value, Worksheets("Sheet2").Range("A:B"), 2, False)
If IsError(hText) Then
hText = ""
Else
ActiveSheet.Hyperlinks.Add Anchor:=myRange, Address:="http://" + hText, TextToDisplay:=myRange.Text
hText = ""
End If
Set myRange = myRange.Offset(1, 0)
Loop
End Sub
The solution is as mentioned by #Rory:
Use the HYPERLINK function in your cell to emulate a hyperlink via a formula.
=HYPERLINK(url, displaytext)
This effectively bypasses the built-in Excel limit on "hard-coded" hyperlinks. Just tested this out after I hit the infamous error 1004:
Application-defined or object-defined error
when trying to create 100k+ hyperlinks in a sheet.
Just regular copy paste should work, but I can update the example (not tested) if it doesn't
Sub AddHyperlinks()
Dim rng As Range, rngFrom As Range, values, r
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1")
Set rngFrom = ThisWorkbook.Worksheets("Sheet2").Range("A:A")
rng.Worksheet.Hyperlinks.Delete ' remove all previous Hyperlinks
While rng(1) > ""
' resize the range to the same values
While rng(rng.Rows.Count + 1) = rng(1)
Set rng = rng.Resize(rng.Rows.Count + 1)
Wend
r = Application.Match(rng(1), rngFrom, 0)
If Not IsError(r) Then
values = rng.Value2 ' save the values
rngFrom(r, 2).Copy rng ' copy from the cell next to the match
rng.Value2 = values ' restore the values (not sure if it removes the links)
End If
Set rng = rng(rng.Rows.Count + 1) ' move to the next cell below
Wend
End Sub
If you store the URL in (eg) colA then something like this should work:
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim URL
If Target.Column <> 1 Then Exit Sub '<< only reacting if cell in URL column is right-clicked
URL = Target.Value
ThisWorkbook.FollowHyperlink URL
End Sub
Alternatively use the Before_DoubleClick event
It does mean you can't use a "friendly" link text such as "click here", but you could likely manage that if you store the URL text at a fixed offset and then read that instead of Target.Value
I suffered from the same problem and I know that I shouldn't have more than around 120000 rows that need hyperlinking so modified some code I found in another thread to this
Sub hyperlink2()
Dim Cell As Range
Dim Cell2 As Range
Dim rng As Range
Dim Rng2 As Range
Set rng = Range("X2:X60000")
For Each Cell In rng
If Cell <> "" Then ActiveSheet.Hyperlinks.Add Cell, Cell.Value
Next
Set Rng2 = Range("X60001:X120000")
For Each Cell2 In Rng2
If Cell2 <> "" Then ActiveSheet.Hyperlinks.Add Cell2, Cell2.Value
Next
End Sub
Hope that helps someone else who stumbles upon this via google (like I did) looking for a workable solution...
The 255 character limit applies to the limit of character that can be put in one cell's formula. A common approach to this is by splitting the link into multiple cells and using a formula to combine them.
=HYPERLINK(A1&A2,"Click Here")
I want to copy and paste values to a range of cells but only if their value = "N/A". I want to leave the formulas as they are in all the cells that do not = "N/A".
In context, I have hundreds of VLOOKUPs. Example:
=IFERROR(VLOOKUP("L0"&MID(G$4,1,1)&"A0"&MID(G$4,1,1)&MID(G$4,3,2)&"-0"&$B6,Sheet1!$C:$D,2,FALSE),"N/A")
Is this possible with VBA?
First of all, you should use real error values rather than string that only look like errors. Secondly, VLOOKUP returns the N/A error directly if the lookup value is not found, so the IFERROR wrapper can be dispenced with. So the formula
=VLOOKUP("L0"&MID(G$4,1,1)&"A0"&MID(G$4,1,1)&MID(G$4,3,2)&"-0"&$B6,Sheet1!$C:$D,2,FALSE)
is sufficient as is.
To replace N/A results with error values, you can use this
Sub Demo()
Dim ws As Worksheet
Dim rngSrc As Range
Dim datV As Variant, datF As Variant
Dim i As Long
' Get range to process by any means you choose
' For example
Set ws = ActiveSheet
With ws
Set rngSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
' Copy data to variant arrays for efficiency
datV = rngSrc.Value
datF = rngSrc.Formula
' replace erroring formulas
For i = 1 To UBound(datV, 1)
If IsError(datV(i, 1)) Then
If datV(i, 1) = CVErr(xlErrNA) Then
datF(i, 1) = CVErr(xlErrNA)
End If
End If
Next
' return data from variant arrays to sheet
rngSrc.Formula = datF
End Sub
If you really want to use strings rather than true error values, adapt the If lines to suit
Rather than loop through all cells in a range, you can use SpecialCells to shorten working with the =NA()cells
This also open up a non-VBA method (if the only error cells are NA, ie no Div#/0)
The first two methods below (manual and code) deal with the situation where you only gave NA cells
the third uses SpecialCells to focus on only the cells that need to be tested, before then running a check for NA before making updates
option1
Manual selection of formula cells that evaluate to errors
Select the range of interest
Press [F5].
Click Special
Select Formulas
check only Errors
option2
VBA updating formula cells that evaluate to errors
code
Sub Shorter()
Dim rng1 As Range
On Error Resume Next
' All error formulas in column A
Set rng1 = Columns("A").SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'update with new value (could be value or formulae)
rng1.Value = "new value"
End Sub
option 3
Test for =NA()
Sub TestSpecificRegion()
Dim rng1 As Range
Dim rng2 As Range
Dim X
Dim lngRow As Long
On Error Resume Next
' All error formulas in column A
Set rng1 = Columns("A").SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'update with new value (could be value or formulae)
For Each rng2 In rng1.Areas
If rng2.Cells.Count > 1 Then
X = rng2.Value2
For lngRow = 1 To UBound(X, 1)
If X(lngRow, 1) = CVErr(xlErrNA) Then X(lngRow, 1) = "new value"
Next
rng2.Value = X
Else
If rng2.Value2 = CVErr(xlErrNA) Then rng2.Value = "new value"
End If
Next
End Sub
This is probably super simple but If I already have a selection how can I add the next row without know necessarily what the next one is?
EDIT
For example if I have the input range "D1:D8" how can I add in the next row, ie "D1:D9" without putting in "D1:D9".
Try
Sub inc_row()
Selection.Resize(Selection.Rows.Count + 1, Selection.Columns.Count).Select
End Sub
This will increase your selection by 1 row, it will also select the new range
Sub test()
Dim rng As Range
Set rng = Range("b2:f5")
Debug.Print rng.Address 'returns $B$2:$F$5
Set rng = rng.Resize(rng.Rows.Count + 1)
Debug.Print rng.Address 'returns $B$2:$F$6
End Sub