I'm having a strange issue with Application.Run in a subprocedure that adds new rows (1 or more depending on user's choice). I wanted to separate the AddRowsBelow() sub so I can reuse it somewhere else too:
Sub AddRowsBelow(Coord As Range, RowsToAdd As Long, Optional SubName As String)
Dim i As Integer
Dim newRowNr As Integer: newRowNr = Coord.Row
For i = 1 To RowsToAdd
Coord.Offset(1).EntireRow.Insert xlDown
If LenB(SubName) <> 0 Then
newRowNr = newRowNr + 1
Application.Run SubName, newRowNr
End If
Next
End Sub
When I pass following sub as an argument, it Debug.Prints rowNr successfuly on each iteration, but the rest of the code only runs once in case of more rows – nothing happens for other iterations. It is run on a range formatted as Excel Table.
Sub FlagAsSublist(rowNr As Integer)
Sheet2.Cells(rowNr, 1).Value = ChrW(sublistFlag)
Debug.Print rowNr
Sheet2.Range(Cells(rowNr, 4), Cells(rowNr, 11)).Borders(xlInsideVertical).ColorIndex = 2
End Sub
Any ideas why it does not work?
Related
Is it possible to speed up the below Sub() that checks for the - character in a range? It is looping over 25000 rows across 3 columns and doesn't perform as fast as I'd like it to.
Sub Character_Check()
For Each tCell In Range("A1:C25000")
If InStr(tCell.Text, "-") > 0 Then
MsgBox "True"
End If
Next
End Sub
Solution:
For these scenarios (massive same computation) I think it's faster to store the values in an array and then just set the results to the range at once. Refer to this answer for a further explanation, by using it, we can see a substantial optimization.
Code
Sub Character_Check_2()
Dim DateTimeReportsRequest As Date: DateTimeReportsRequest = Now()
Dim arrMark As Variant
Dim CounterRow As Long
Dim CounterCol As Long
ReDim arrMark(1 To Cells.SpecialCells(xlCellTypeLastCell).Row, 1 To 1)
For CounterCol = 1 To 3 'A to C
For CounterRow = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row 'Rows 2 to 25k
If InStr(Cells(CounterRow, CounterCol).Text, "-") > 0 Then arrMark(CounterRow, 1) = "TRUE"
Next CounterRow
Next CounterCol
With Cells(1, 5).Resize(UBound(arrMark), 1)
.Value = arrMark
End With
MsgBox "Time to finish: " & DateDiff("s", DateTimeReportsRequest, Now()) & " seconds", vbOKOnly
End Sub
Demo
Testing for the 25k in 3 columns (assuming it needs to write it to the sheet which it's very demanding), we go from 11secs to ~1
Try the below simple alternative and see if it improves the performance:
Sub Find_All()
Dim rangeFirst As Range, rangeCurrent As Range
Dim searchRange As Range
Set searchRange = Range("A1:C25000")
Do
If rangeFirst Is Nothing Then
Set rangeFirst = searchRange.Find(What:="-")
Set rangeCurrent = rangeFirst
Else
Set rangeCurrent = searchRange.Find(What:="-", After:=rangeCurrent)
If rangeCurrent.Address = rangeFirst.Address Then Exit Do
End If
MsgBox (rangeCurrent)
Loop
End Sub
Function test()
Dim result As String
Dim x As Integer
Dim search_value As String
Dim column As Integer
search_value = "esg001"
column = 1
For x = 2 To 3
Sheets(x).Select
Range("B:B").Select
On Error Resume Next
Cells.Find(search_value).Select
ActiveCell.Offset(0, column).Select
result = ActiveCell.Value
If search_value <> "" Then
GoTo ola
Else
End If
Next
ola:
test = result
End Function
as stated in the comments the following formula will do what you want:
=IFERROR(VLOOKUP("esg001",Sheet2!B:C,2,FALSE),VLOOKUP("esg001",Sheet3!B:C,2,FALSE))
Where Sheet2 and Sheet3 are the names of the sheets.
Now a couple of notes on your attempted code.
Do not use .Select. More info on that HERE
when using UDF avoid hardcoding ranges, pass them as parameters. The reason is that the formula would not update when the data updates if it is not a parameter.
This accepts two parameters: Search Value and which column to return. It also accepts as many ranges as desired to search for the value:
Function test(schVal As String, clm As Long, ParamArray schRng() As Variant) As Variant
Dim i As Long
For i = LBound(schRng) To UBound(schRng)
If TypeOf schRng(i) Is Range Then
If schRng(i).Columns.Count > clm Then Exit Function
Dim rngArr() As Variant
rngArr = Intersect(schRng(i), schRng(i).Parent.UsedRange).Value
Dim j As Long
For j = 1 To UBound(rngArr, 1)
If rngArr(j, 1) = schVal Then
test = rngArr(j, clm)
Exit Function
End If
Next j
Else
test = "Parameters 3 and higher should be ranges"
Exit Function
End If
Next i
test = "Not Found"
End Function
Now you would call it (using the formula above as a template):
=TEST("esg001",2,Sheet2!B:C,Sheet3!B:C)
It will first
This is my first project using Excel-VBA. I've figured out how to use VBA code to do most of what I've wanted. I'm now trying to copy data to a new cell, and then I want to copy a range, but not copy down the data of new cell and leave it blank below. I've only been able to leave the copied data in it's exact place and not move down with the range copies. I don't know if it's possible to do what I want, or if I just don't know how. Any help would be greatly appreciated!
Sub AddHeader()
Range("CA1").Formula = "Stay Date"
End Sub
=====================================
Sub CellCopy()
Range("H2:H4000").Copy Range("CA2")
End Sub
=====================================
Sub CopyData()
Dim xRow As Long
Dim VInSertNum As Variant
xRow = 1
Application.ScreenUpdating = False
Do While (Cells(xRow, "A") <> "")
VInSertNum = Cells(xRow, "P")
If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
Range(Cells(xRow, "A"), Cells(xRow, "BZ")).Copy
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "BZ")).Select
Selection.Insert Shift:=xlDown
xRow = xRow + VInSertNum - 1
End If
xRow = xRow + 1
Loop
Application.ScreenUpdating = False
End Sub
=====================================
Sub RunAllMacros()
AddHeader
CellCopy
CopyData
End Sub
Your question isn't entirely clear but if I understand correctly, you want to:
Repeat each row in your worksheet n times (where n is read from the worksheet itself and each row has its own n value).
There are certain columns you want to exclude from being repeated.
I would add that:
It might be better to loop in reverse order (so that row insertions do not affect the iterator/variable keeping track of loop progress).
Have you considered copying the entire row (Range.EntireRow) and then using Range.Clear to clear those columns which you didn't want repeated?
It's always good to include an example of input and expected output. Otherwise, it's difficult for the responder to verify their own answer.
The code below:
Option Explicit
Private Sub AddHeader(ByVal someSheet As Worksheet)
someSheet.Range("CA1").Formula = "Stay Date"
End Sub
Private Sub CellCopy(ByVal someSheet As Worksheet)
someSheet.Range("H2:H4000").Copy someSheet.Range("CA2")
End Sub
Private Sub RunAllMacros()
Dim sheetToModify As Worksheet
Set sheetToModify = ActiveSheet ' Better to replace with something like ThisWorkbook.Worksheets("Sheet1")
AddHeader sheetToModify
CellCopy sheetToModify
CopyData sheetToModify
End Sub
Private Sub CopyData(ByVal someSheet As Worksheet)
Dim lastRow As Long
lastRow = someSheet.Cells(someSheet.Rows.Count, "A").End(xlUp).Row
Dim rowIndex As Long
For rowIndex = lastRow To 2 Step -1 ' Presume you want to skip headers?
Dim numberOfTimesToRepeatRow As Variant
numberOfTimesToRepeatRow = someSheet.Cells(rowIndex, "P") ' Will need to -1 as count includes the row being copied.
If IsGreaterThanOne(numberOfTimesToRepeatRow) Then
With someSheet.Range("A" & rowIndex, "CA" & rowIndex)
.Copy
.Offset(1).Resize(numberOfTimesToRepeatRow - 1).Insert Shift:=xlDown
' Have to repeat/re-evaluate (cannot use With or
' object reference since rows have been inserted)
.Offset(1).Resize(numberOfTimesToRepeatRow - 1).Columns("CA").Clear
End With
End If
Next rowIndex
Application.CutCopyMode = False
End Sub
Private Function IsGreaterThanOne(ByVal someValue As Variant)
' Dedicated function to reduce indentation in caller.
' Returns True if value is numeric AND greater than 1 (else
' False).
' Separate IF statements since no short-circuit
' evaluation -- meaning non-numeric values could otherwise
' cause type mismatch error.
If IsNumeric(someValue) Then
If someValue > 1 Then
IsGreaterThanOne = True
End If
End If
End Function
The code above keeps the value in column CA for only the original rows -- and not for the newly inserted rows. In the other words, there are blanks in column CA of the newly inserted rows.
Hope that makes sense and gives you some idea on how to achieve this. If I've misunderstood, you can let me know.
Manual - Select range, execute Sub
How it works - Sub saves all non-blank cells to finalArray that is ultimately displayed in the selected range
What's the problem - if range contains cells with hyperlinks created via insert-hyperlink, the hyperlinks disappear.
Sub RemoveBlanks()
'i,j - counters, k - offset
Dim finalArray() As Variant
ReDim finalArray(Selection.Rows.Count, 1)
k = 1
For i = 1 To Selection.Rows.Count
If Selection(i, 1) <> "" Then
finalArray(k, 1) = Selection(i, 1)
k = k + 1
End If
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
Selection.Clear
For i = 1 To k
Selection(i, 1).Value = finalArray(i, 1)
Next i
End Sub
This Code will loops through each cell in the selected range, checks if the cell has a hyperlink then temporarily grab and store the address that it’s pointing to re-apply the hyperlink
Option Explicit
Sub fixHyperlinks()
Dim rng As Range
Dim address As String
Application.ScreenUpdating = False
For Each rng In Selection
If rng.Hyperlinks.Count > 0 Then
address = rng.Hyperlinks(rng.Hyperlinks.Count).address
rng.Hyperlinks.Add Anchor:=rng, _
address:=address
End If
Next
Application.ScreenUpdating = True
End Sub
After you run this code, you should be able to set in your array the range without losing your links.
Conclusion : Run this code before you run your macro.
So I have found a way around the issue after lurking through internet and trying to save links in another array (fails). It works only if the value in the cell is the same as name of a sheet, yet it solves my issue so far.
Sub CreateLinks()
'i - counter, the title as i=1 is omitted. Code uses value stored in cell to
'transform it into a link.
Dim i As Integer
For i = 2 To Selection.Rows.Count
If Selection(i) <> "" Then
ActiveSheet.Hyperlinks.Add anchor:=Selection(i), _
address:="#'" & CStr(Selection(i)) & "'!A1", _
TextToDisplay:=CStr(Selection(i))
End If
Next i
End Sub
I wanted to check if an excel range in empty in a section of code in user module.
I used the below code
Worksheets(yearsheet).Range("N" & rownum & ":DI").Select
If Application.WorksheetFunction.CountA(Selection) = 0 Then
Exit Sub
End If
I'm getting runtime error 1004. Can anyone tell whats my mistake?
Thanks in advance.
PS: rownum is integer variable and yearsheet is string variable. both these variables were updated properly in code prior to the above section of the code
"N" & rownum & ":DI" doesn't evaluate to a real address because it's missing the row number for the second half of the address. Also, you should avoid using Select statement whenever possible.
Assuming the whole range is in one row, this would work:
Sub test()
Dim yearsheet As String
Dim rownum As Integer
yearsheet = "Sheet2"
rownum = 2
If Application.WorksheetFunction.CountA(Worksheets(yearsheet) _
.Range("N" & rownum & ":DI" & rownum)) = 0 Then
Exit Sub
End If
End Sub
The best way to test if a selection is (not) empty in VBA:
' Tests if a selection of cells exists.
' #return true or false
Function isCellSelection() As Boolean
Dim r As range
isCellSelection = False
Set r = Selection.Cells
If IsEmpty(r) Then
isCellSelection = True
End If
End Function ' isCellSelection