I have an excel sheet where the columns and rows of the table are changed from time to time. The affected vba script, however, uses fixed values for rows and columns. How can I find the columns and rows if they change? The name of the columns is not changed, but only the location in the sheet.
I have to upadte my method manually everytime. (Like you see in the code example)
Hello Siddharth, thank you for your detailed description. Unfortunately I do not have experience with VBA, so I can not support the integration of your code. I suspect that the return variable does not match the specified method. Here is my VBA script that needs to be extended. I hope you can help me there =)
Option Explicit
Public Sub moduleStatus()
Dim iQZeMax As Integer
Dim iQZe As Integer
Dim iZZe As Integer
Dim iQSp As Integer
Dim shtSPR_R As Worksheet, shtAdd As Worksheet
Dim rng_2_check As Range
Dim lstLong(3) As String
lstLong(0) = "Initiated"
lstLong(1) = "Review ready"
lstLong(2) = "Reviewed"
Dim lstShort(2) As String
lstShort(0) = "Initiated"
lstShort(1) = "Review ready"
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtSPR_R = ThisWorkbook.Sheets("Report")
Set shtAdd = ThisWorkbook.Sheets("Add")
'Unprotect
shtSPR_R.Unprotect
'Clear old Data
'''shtSPR_R.Range("AB11:AB10000").ClearContents
'Status
iQSp = 28
'''iQZe = 11
'max row is determined by MA
For iQZeMax = 10010 To 1 Step -1
If shtSPR_R.Range("A" & iQZeMax).Value <> "" Or shtSPR_R.Range("B" & iQZeMax).Value <> "" Then Exit For
Next
shtSPR_R.Range("AC11:AD10010").Clear
shtSPR_R.Range("A1").FormatConditions(1).ModifyAppliesToRange Range:=shtSPR_R.Range("A1:AE10010")
For iQZe = 11 To iQZeMax
' If Application.WorksheetFunction.CountIfs(shtSPR_R.Range("A" & iQZe & ":AB" & iQZe), "") = iQSp Then
' Exit For
' End If
'Case Initiated
If shtSPR_R.Range("AB" & iQZe).Value = "" Then
shtSPR_R.Range("AB" & iQZe).Validation.Delete
shtSPR_R.Range("AB" & iQZe).Value = "Initiated"
shtSPR_R.Cells(iQZe, iQSp).Validation.Add _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=Join(lstShort, ",")
End If
If Application.WorksheetFunction.CountIfs(shtSPR_R.Range("A9:AB9"), "Required", shtSPR_R.Range("A" & iQZe & ":AB" & iQZe), "") <> 0 Then
shtSPR_R.Range("AB" & iQZe).Validation.Delete
shtSPR_R.Range("AB" & iQZe).Validation.Add _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=Join(lstShort, ",")
Else
shtSPR_R.Range("AB" & iQZe).Validation.Delete
shtSPR_R.Cells(iQZe, iQSp).Validation.Add _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=Join(lstLong, ",")
End If
'shtSPR_R.Range("AC" & iQZe).FormulaArray = "=IFERROR(INDEX(general_report!R3C5:R10000C5,MATCH(RC[-27]&RC[-26]&RC[-22],general_report!R3C8:R10000C8&general_report!R3C2:R10000C2&general_report!R3C9:R10000C9,0)),""tbd."")"
'shtSPR_R.Range("AD" & iQZe).FormulaArray = "=IFERROR(INDEX(general_report!R3C6:R10000C6,MATCH(RC[-28]&RC[-27]&RC[-23],general_report!R3C8:R10000C8&general_report!R3C2:R10000C2&general_report!R3C9:R10000C9,0)),""tbd."")"
shtSPR_R.Range("AC" & iQZe).FormulaArray = "=IFERROR(INDEX(general_report!R4C6:R10000C6,MATCH(RC[-27]&RC[-26]&RC[-22],general_report!R4C9:R10000C9&general_report!R4C2:R10000C2&general_report!R4C10:R10000C10,0)),""tbd."")"
shtSPR_R.Range("AD" & iQZe).FormulaArray = "=IFERROR(INDEX(general_report!R4C7:R10000C7,MATCH(RC[-28]&RC[-27]&RC[-23],general_report!R4C9:R10000C9&general_report!R4C2:R10000C2&general_report!R4C10:R10000C10,0)),""tbd."")"
If shtSPR_R.Range("AB" & iQZe).Value = "Exported" Then
shtSPR_R.Range("A" & iQZe & ":AA" & iQZe).Locked = True
Else
shtSPR_R.Range("A" & iQZe & ":AA" & iQZe).Locked = False
End If
If shtSPR_R.Range("AE" & iQZe).Value = "" Then
shtAdd.Range("rngSPR_ID_Cnt").Value = shtAdd.Range("rngSPR_ID_Cnt").Value + 1
shtSPR_R.Range("AE" & iQZe).Value = shtSPR_R.Range("L" & iQZe).Value & "-" & Right("00000" & shtAdd.Range("rngSPR_ID_Cnt").Value, 5)
End If
Next iQZe
'Protect
shtSPR_R.Protect "", DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowFiltering:=True
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Done!"
End Sub
Here is another way to do it.
What you are actually trying to get is the R4C6:R10000C6 part of the formula. So what you can do is use a common sub to get the address and then create your own formula string. I am using .Find to locate the column header. To read more about .Find, you can see .Find and .FindNext
Here is an example for Linked Issues.
Option Explicit
Sub Sample()
Debug.Print GetAddress("Linked Issues")
End Sub
Private Function GetAddress(ColHeader As String) As String
Dim HeaderRow As Long, HeaderCol As Long
Dim rngAddress As String: rngAddress = "Not Found"
Dim aCell As Range
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
Set aCell = .Cells.Find(What:=ColHeader, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
HeaderRow = aCell.Row
HeaderCol = aCell.Column
rngAddress = "R" & (HeaderRow + 1) & "C" & HeaderCol & _
":R10000C" & HeaderCol
End If
End With
GetAddress = rngAddress
End Function
CAUTION: You may get false positives if the column name is repeated elsewhere. I have used LookAt:=xlWhole to minimize that but you still need to be careful.
Screenshot:
When you run the code you will get R4C3:R10000C3
Also if you want to avoid the hardcoding of 10000, then find the last row. For that you can see THIS
Create a new spreadsheet, let's say "keys"
The 1st column of which will be "columns" and the 3rd of which will be rows,
then you add a MATCH function, that gives you the location of the row and column,
so what you'll need to do is link the VBA to keys sheet, and grab the location from there
The formula for each column:
IFERROR(ADDRESS(1,MATCH($A2,'1'!$A$1:$A$1000,0)),"missing")
IFERROR(ADDRESS(MATCH($C2,'1'!$A$2:$BA$2,0),2),"missing")
And lastly, connect the formulas' results witho your VBA:
shtSPR_R.Range("keys!B2").FormulaArray = ...
Hope that helps
Related
I have a macro that looks below header names for items if there is an item it will make it a drop down. Headers are in the 7th row so it starts looking from row 8 and on. The code runs perfectly, except if there is no items below the headers.
Sometimes the user does not need any drop downs for the sheet so they will leave all rows below the headers blank. Which is great for what I am doing but will make the macro throw errors as there is no items to be found.
I essentially need to tweak my code so it is able to stop or exit if no cells are found. This is the macro I need to tweak.
Sub AddDropDowns()
Dim cell As Range
Dim iDropDown As Long
With Worksheets("Sheet1")
For Each cell In .Range("B8", .Cells(8, .Columns.Count).End(xlToRight)).SpecialCells(XlCellType.xlCellTypeConstants)
AddDropDown Worksheets("DropDownsTT"), iDropDown, cell.Offset(-1).Value, "='" & .Name & "'!" & cell.Resize(WorksheetFunction.CountA(cell.EntireColumn) - 1).Address
Next cell
End With
End Sub
Not sure if this piece of code is needed but the macro calls the following subroutine:
Sub AddDropDown(sht As Worksheet, dropDownCounter As Long, header As String, validationFormula As String)
With sht.Range("A1").Offset(, dropDownCounter) '<--| reference passed sheet row 1 passed column
.Cells(1, 1) = header '<--| write header
With .Cells(2, 1).Validation '<--| reference 'Validation' property of cell 1 row below currently referenced one
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=validationFormula
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End With
dropDownCounter = dropDownCounter + 1
End Sub
You could do this:
Dim rng As Range
'...
With Worksheets("Sheet1")
On Error Resume Next
Set rng = .Range("B8", .Cells(8, .Columns.Count).End( _
xlToRight)).SpecialCells(XlCellType.xlCellTypeConstants)
On Error Goto 0
If Not rng Is Nothing Then
For Each cell In rng
AddDropDown Worksheets("DropDownsTT"), iDropDown, _
cell.Offset(-1).Value, "='" & .Name & "'!" & _
cell.Resize(WorksheetFunction.CountA(cell.EntireColumn) - 1).Address
Next cell
End If
End With
but that's kind of untidy, so I would probably use something like:
With Worksheets("Sheet1")
For Each cell In .Range("B8", .Cells(8, .Columns.Count).End( xlToRight))
If Len(cell.Value) > 0 Then
AddDropDown Worksheets("DropDownsTT"), iDropDown, _
cell.Offset(-1).Value, "='" & .Name & "'!" & _
cell.Resize(WorksheetFunction.CountA(cell.EntireColumn) - 1).Address
End If
Next cell
End With
I use the following formula in excel
=AVERAGEIFS(B4:B440;A4:A440;"<"&A441;A4:A440;">"&EDATE(A441;-6))
to get the average of a range of values, based on the values in an adjacent column. However I need to apply this formula for more than a thousand dates (column A contains dates). I have a macro, which asks the user to specify sheet name and date (using dialog boxes). So I would like to add some code, that takes the date specified by the user and replaces cell A441 from the above formula with it. Then copy the average, so that I can paste it where desired. Here is what I tried coding so far, with no success:
Sub Find()
Dim FindString As Date
Dim Sumact As Range
Dim Analyst As Double
Dim shname As String
Do Until WorksheetExists(shname)
shname = InputBox("Enter sheet name")
If Not WorksheetExists(shname) Then MsgBox shname & " doesn't exist!", vbExclamation
Loop
Sheets(shname).Select
FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
With Sheets(shname).Range("A:A")
Set Sumact = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Sumact Is Nothing Then
Application.Goto Sumact, True
Else
MsgBox "Nothing found"
End If
End With
End If
Set Analyst = Application.AverageIf(Range(("B:B"), ("A:A")), "<Sumact")
Selection.Copy
End Sub
You do not Set a variable unless you are setting an object like the cell returned by the Range.Find method. Assigning a double to a var should be simply equal (e.g. =).
Sub Make_AVERAGEIFS()
Dim FindString As Date
Dim Sumact As Range
Dim Analyst As Double
Dim shname As String
Dim d As Integer, m As Integer, y As Integer
Do Until WorksheetExists(shname)
shname = InputBox("Enter sheet name")
If Not WorksheetExists(shname) Then MsgBox shname & " doesn't exist!", vbExclamation
Loop
With worksSheets(shname)
.Activate
FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
With .Range("A:A")
Set Sumact = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Sumact Is Nothing Then
Application.Goto Sumact, True
Else
MsgBox "Nothing found"
End If
End With
End If
If IsDate(Sumact) Then
d = Day(Sumact): m = Month(Sumact): y = Year(Sumact)
Analyst = Application.AverageIfs(.Columns(2), _
.Columns(1), "<" & DateSerial(y, m, d), _
.Columns(1), ">" & DateSerial(y, m - 6, d))
End If
End With
Selection.Copy
End Sub
I suppose that searching for the date in column A is one way to check that the user has input a valid date but there must be other, less complicated methods. The IsDate Function that I have used above is one.
I am trying to write a macro that will prompt the user to enter a value and do the following:
- Search for the value in column B and select the first cell where the value is found
- Return the correspondong value in column L and M of the selected cell's row within a message box
- Then once the user hits "ok", the macro will find and select the next cell in column B with the search criteria, and repeat the above steps
- Once all of the cells with the search criteria in column B have been searched and found, a message box will communicate that all matches have been found and close loop
Below is the code I have started out with, and being a beginner with VB, I can't figure out why my loop isn't working correctly... Please help!
Sub Macro1()
Dim response As String, FndRow As Long, NoMatch As Boolean, LastRow As Long
response = InputBox("Please enter the Column Name to find matching Source File Field Name.")
If response = "" Then Exit Sub
On Error Resume Next
Range("B5").Select
NoMatch = False
LastRow = 0
Do Until NoMatch = True
FndRow = Cells.Find(What:=response, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
If FndRow = 0 Then
MsgBox response & " could not be found."
NoMatch = True
ElseIf FndRow < LastRow Then
MsgBox "All " & response & " matches have been found."
NoMatch = True
Else
Range("B" & FndRow).Select
MsgBox "Source File Name: " & Range("L" & FndRow).Value & vbNewLine & "File Column Name: " & Range("M" & FndRow).Value
LastRow = FndRow
End If
Loop
End Sub
I would use a filter instead of a find loop:
Sub tgr()
Dim rngVis As Range
Dim VisCell As Range
Dim sFind As String
sFind = InputBox("Please enter the Column Name to find matching Source File Field Name.")
If Len(Trim(sFind)) = 0 Then Exit Sub 'Pressed cancel
Application.ScreenUpdating = False
With Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("B"))
.AutoFilter 1, sFind
On Error Resume Next
Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
End With
Application.ScreenUpdating = True
If rngVis Is Nothing Then
MsgBox sFind & " could not be found."
Else
For Each VisCell In rngVis.Cells
MsgBox "Source File Name: " & VisCell.Worksheet.Cells(VisCell.Row, "L").Text & vbNewLine & _
"File Column Name: " & VisCell.Worksheet.Cells(VisCell.Row, "M").Text
Next VisCell
End If
End Sub
your Find is acting strangely because you are looking for match 'horizontally'. You need to use SearchOrder:=xlByColumns
FndRow = Cells.Find(What:=response, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
I would like to use values from each instance of the string FindString to populate textboxes in UserForm1.
I am getting the unique WorkSheet per textbox. But the rest of the values are from the sheet active when I run the module.
This mean the string Rng isn't looping through the WorkSheets, but staying with the initial WorkSheet. How can I remedy this?
Public Sub FindString()
Dim FindString As Variant
Dim Rng As Range
Dim SheetName As String
Dim ws As Worksheet
Dim i As Integer
Application.ScreenUpdating = False
SheetName = ActiveSheet.Name
FindString = Cells(ActiveCell.Row, 1).Value
FindString = InputBox("Enter the case number to search for:", "Case ID", FindString)
If FindString = "" Then Exit Sub
If FindString = False Then Exit Sub
i = 1
For Each ws In Worksheets
If ws.Name Like "Lang*" Then
With ws
If Trim(FindString) <> "" Then
With Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
UserForm1.Controls("TextBox" & i) = ws.Name & vbTab & _
Rng.Offset(0, 2).Value & vbTab & _
Rng.Offset(0, 5).Value & vbTab & _
Rng.Offset(0, 6).Value & vbTab & _
Rng.Offset(0, 7).Value & vbTab & _
Rng.Offset(0, 8).Value
i = i + 1
Else: GoTo NotFound
End If
End With
End If
End With
End If
Next ws
Sheets(SheetName).Activate
Application.ScreenUpdating = True
UserForm1.Show
Exit Sub
NotFound:
Sheets(SheetName).Activate
Application.ScreenUpdating = True
MsgBox "Case ID not found"
Exit Sub
End Sub
Got it!
Just needed to add
ws.Activate
after
If ws.Name Like "Lang*" Then
I have a block of code that takes way too long to process for some files. Smaller files (fewer lines of data) work fine, but once I get to about 150-300, it starts to get slow, (sometimes I think the whole process actually just hangs) and I have to run this sometimes on files with up to 6,000.
I want to plug in a VLookup() function in the .FormulaR1C1 for a number of cells. I know that I can set the whole range at once using .Range("J2:J" & MaxRow). However, I am looping through a block of cells to check the value of those cells. IF they are empty, THEN I want to apply the formula. If those cells already have values, then I don't want to change them, so I don't think the whole range option will work for me (at least I was unable to get it right).
Private Sub PullMIAFinalizedData(NewMIARep As Worksheet, MaxRow As Long, wkbFinalized As Workbook)
Dim wksFinalized As Worksheet
Dim lCount As Long
Dim sVLookupJBlock As String
Dim sVLookupKBlock As String
Application.Calculation = xlCalculationManual
sVLookupJBlock = "=IF(ISERROR(" & _
"VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C13,13,FALSE))," & _
Chr(34) & Chr(34) & _
",VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C13,13,FALSE))"
sVLookupKBlock = "=IF(ISERROR(" & _
"VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C3,3,FALSE))," & _
Chr(34) & Chr(34) & _
",VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C3,3,FALSE))"
For Each wksFinalized In wkbFinalized.Sheets
ShowAllRecords wksFinalized 'Custom Function to unhide/unfilter all data
With NewMIARep
For lCount = 2 To MaxRow
If .Range("J" & lCount).value = "" And .Range("K" & lCount).value = "" Then
.Range("J" & lCount).FormulaR1C1 = sVLookupJBlock
.Range("K" & lCount).FormulaR1C1 = sVLookupKBlock
Application.Calculate
With .Range("J" & lCount & ":K" & lCount)
.value = .value
End With
End If
Next lCount
.Range("J2:J" & MaxRow).NumberFormat = "mm/dd/yyyy"
End With
Next wksFinalized
Application.Calculation = xlCalculationAutomatic
End Sub
Am I just stuck with this?
Thanks very much to assylias and Siddharth Rout for helping out with this; both provided very useful information, which led to this result:
Private Sub PullMIAFinalizedData(NewMIARep As Worksheet, MaxRow As Long, wkbFinalized As Workbook)
Dim wksFinalized As Worksheet
Dim lCount As Long
Dim lFinMaxRow As Long
Dim DataRange As Variant 'per assylias, using a variant array to run through cells
Dim FoundRange As Range
Application.Calculation = xlCalculationManual
With NewMIARep
DataRange = .Range("J2:K" & MaxRow)
For Each wksFinalized In wkbFinalized.Sheets
ShowAllRecords wksFinalized
lFinMaxRow = GetMaxRow(wksFinalized)
If lFinMaxRow > 1 Then
For lCount = 1 To MaxRow - 1
If Len(DataRange(lCount, 1)) = 0 And Len(DataRange(lCount, 2)) = 0 Then
'per Siddharth Rout, using Find instead of VLookup
Set FoundRange = wksFinalized.Range("A2:A" & lFinMaxRow).Find(What:=.Range("A" & lCount).value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not FoundRange Is Nothing Then
DataRange(lCount, 1) = FoundRange.Offset(ColumnOffset:=12).value
DataRange(lCount, 2) = FoundRange.Offset(ColumnOffset:=2).value
Set FoundRange = Nothing
End If
End If
Next lCount
End If
Next wksFinalized
.Range("J2:K" & MaxRow).value = DataRange
.Range("J2:J" & MaxRow).NumberFormat = "mm/dd/yyyy"
End With
Application.Calculation = xlCalculationAutomatic
End Sub
You don't want to iterate on cells from VBA: it is EXTREMELY slow. Instead, you put the data you need into an array, work on the array and put the data back to the sheet. In your case, something like the code below (not tested):
Dim data as Variant
Dim result as Variant
Dim i as Long
data = ActiveSheet.UsedRange
ReDim result(1 To UBound(data,1), 1 To UBound(data,2)) As Variant
For i = LBound(data,1) to UBound(data,1)
'do something here, for example
If data(i,1) = "" Then
result(i,1) = "=VLOOKUP($A1,$A:$G," & i & ",FALSE)"
Else
result(i,1) = data(i,1)
End If
Next i
ActiveSheet.Cells(1,1).Resize(Ubound(result, 1), UBound(result,2)) = result