Trying to make a VBA Code which performs the following action.
That If Sheet1.Range("B7").Value = 2002_2550 or Text or Number
then Find that value in Sheet14.Range("A:A") If that number Matches then then copy the same cell of Col"B"
and then paste copied value in to Sheet4.Range("f11:f100") till the ColE used range.
I have tried with below code but nothing happened.
Sub Match()
Sheet4.Range("f11:f100").Value = WorksheetFunction.Match(Sheet1.Range("B7").Value, Sheet14.Range("A2), 0)
End Sub
Make this as well but nothing is working.
Sub FindStr()
Dim rFndCell As Range
Dim stFnd As String
Dim fCol As Integer
stFnd = Sheet1.Range("B7").Value
Set rFndCell = Sheet14.Range("A:A").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then
fCol = rFndCell.Column
Sheet14.Range("B3:B33").Copy Sheet4.Range("F100:F100")
Else 'Can't find the item
MsgBox "No Find"
End If
End Sub
Please, try the next code line:
Dim lastR4 As Long
lastR4 = Sheet4.Range("E" & rows.count).End(xlUp).row 'last row on E:E col
Sheet4.Range("F11:F" & lastR4).Value = Sheet14.Range("A" & _
WorksheetFunction.match(Sheet1.Range("B7").Value, Sheet14.Range("A:A"), 0)).Offset(0, 1)
Related
I am trying to search for values listed in a column from multiple sheets in my excel workbook. If excel finds a match I would like it to return sheet names of the tabs that had the value.
Here is what i have done so far. I decided to start off by using one keyword to search multiple tabs, copy and paste the sheet name. The code below only paste the first resulting sheet name when there are other sheets containing the same keyword. I would like to know how i can pull the other sheet names that contain the same keyword.
I would also like to know how i can set up the keyword to use information in Column A of the Field List.
Sub FinalAppendVar()
Dim ws As Worksheet
Dim arr() As String
Keyword = "adj_veh_smart_tech_disc"
Totalsheets = Worksheets.Count
For i = 1 To Totalsheets
If Worksheets(i).Name <> "Main" Or InStr(1, Worksheets(i).Name, " Checks") Or Worksheets(i).Name
<>_ "Field Lists" Then
lastrow = Worksheets(i).Cells(Rows.Count, 4).End(xlUp).Row
For j = 2 To lastrow
If Worksheets(i).Cells(1, 3).Value = Keyword Then
Worksheets("Field Lists").Activate
lastrow = Worksheets("Field Lists").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Field Lists").Cells(lastrow + 1, 5).Value = Worksheets(i).Name
Worksheets("Field Lists").Cells(lastrow + 2, 5).Value = Worksheets(i).Name
End If
Next
End If
Next
End Sub
The following code should work for what you described.
A couple feedback items:
Tabbing out loops and if statements significantly improves code readability
Never reuse variable names (i.e. lastrow), it makes it hard to read and can cause issues that are difficult to find later on
Follow all Next with the loop variable (i.e. Next i), this improves readability and helps you keep track of the ends of loops
.Activate and .Select are generally never required in vba, its better to be explicit in what you are referencing
Sub FinalAppendVar()
Dim searchSheet As Excel.Worksheet
Dim pasteSheet As Excel.Worksheet
Dim keyword As String
Dim lastSearchRow As Integer
Dim lastPasteRow As Integer
' set the worksheet to paste to
Set pasteSheet = ThisWorkbook.Worksheets("Field Lists")
' set keyword to look for
keyword = "adj_veh_smart_tech_disc" '<-- manual entry
'keyword = pasteSheet.Range("A1").Value '<-- use value in cell A1 on the defined pasteSheet
' loop through all sheets in the workbook
For i = 1 To ThisWorkbook.Worksheets.Count
' set the current worksheet we are looking at
Set searchSheet = ThisWorkbook.Worksheets(i)
' check if the current sheet is one we want to search in
If searchSheet.Name <> "Main" Or InStr(1, searchSheet.Name, " Checks") Or searchSheet.Name <> "Field Lists" Then
' current worksheet is one we want to search in
' find the last row of data in column D of the current sheet
lastSearchRow = searchSheet.Cells(1048576, 4).End(xlUp).Row
' loop through all rows of the current sheet, looking for the keyword
For j = 2 To lastSearchRow
If searchSheet.Cells(j, 3).Value = keyword Then
' found the keyword in row j of column C in the current sheet
' find the last row of column D in the paste sheet
'lastPasteRow = pasteSheet.Cells(1048576, 4).End(xlUp).Row
lastPasteRow = pasteSheet.Cells(1048576, 5).End(xlUp).Row '<-- update based on OPs comment
' paste the name of the current search sheet to the last empty cell in column E
pasteSheet.Cells(lastPasteRow + 1, 5).Value = searchSheet.Name
' not sure if the next line is needed, looks like it pastes again immediately below the previous
pasteSheet.Cells(lastPasteRow + 2, 5).Value = searchSheet.Name
' to save time consider exiting the search in the current sheet since the keyword was just found
' this will move to the next sheet immediately and not loop through the rest of the rows on the current
' search sheet. This may not align with the usecase so it is currently commented out.
'Exit For '<--uncomment this to move to the next sheet after finding the first instance of the keyword
Else
' the keyoword was not in row j of column C
' do nothing
End If
Next j
Else
' current sheet is one we don't want to search in
' do nothing
End If
Next i
End Sub
Please try this variant (Don't worry that the code is so long - the longer the programmer thought and the more wrote, the better the program works ... usually it is):
Option Explicit
Sub collectLinks()
Const LIST_SHEET_NAME As String = "Field Lists"
Dim wsTarget As Worksheet
Dim wsEach As Worksheet
Dim keywordCell As Range
Dim sKeyword As String
Dim linkCell As Range
Dim aFound As Range
Dim aCell As Range
On Error Resume Next
Set wsTarget = ActiveWorkbook.Worksheets(LIST_SHEET_NAME)
On Error GoTo 0
If wsTarget Is Nothing Then
MsgBox "'" & LIST_SHEET_NAME & "' not exists in active workbook", vbCritical, "Wrong book or sheet name"
Exit Sub
End If
Rem Clear all previous results (from column B to end of data)
wsTarget.UsedRange.Offset(0, 1).ClearContents
Rem Repeat for each cell of column A in UsedRange:
For Each keywordCell In Application.Intersect(wsTarget.UsedRange, wsTarget.Columns("A")) ' It can be changed to "D", "AZ" or any other column
sKeyword = keywordCell.Text
If Trim(sKeyword) <> vbNullString Then
Application.StatusBar = "Processed '" & sKeyword & "'"
Set linkCell = keywordCell
For Each wsEach In ActiveWorkbook.Worksheets
If wsEach.Name <> LIST_SHEET_NAME Then
Application.StatusBar = "Processed '" & sKeyword & "' Search in '" & wsEach.Name & "'"
Set aFound = FindAll(wsEach.UsedRange, sKeyword)
If Not aFound Is Nothing Then
For Each aCell In aFound
Set linkCell = linkCell.Offset(0, 1) ' Shift to rught, to the next column
linkCell.Formula2 = "=HYPERLINK(""#" & aCell.Address(False, False, xlA1, True) & """,""" & _
aCell.Worksheet.Name & " in cell " & aCell.Address(False, False, xlA1, False) & """)"
Next aCell
End If
End If
Next wsEach
End If
Next keywordCell
Application.StatusBar = False
Rem Column width
wsTarget.UsedRange.Columns.AutoFit
End Sub
Function FindAll(SearchRange As Range, FindWhat As Variant) As Range
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
Rem If your keyword can be a part of cell then change parameter xlWhole to xlPart:
Set FoundCell = SearchRange.Find(FindWhat, LastCell, xlValues, xlWhole, xlByRows)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
You can see how it works in this demo workbook - Create Links To Keywords.xlsm
EDIT By the way, the second part of this code, the FindAll() function, is a slightly shortened version of the Chip Pearson macro. Keep this link for yourself, there are many useful things to help you in future development.
I need a macro to add text to blank cells in Column A. The macro needs to skip cells that have text. The macro needs to stop looping at the end of the data set.
I am trying to use an If Else statement, but I think I'm on the wrong track. My current, non-working code is below. Thank you so much - I'm still new to VBA
Sub ElseIfi()
For i = 2 To 100
If Worksheets("RawPayrollDump").Cells(2, 1).Value = "" Then
Worksheets("RawPayrollDump").Cells(2, 1).Value = "Administration"
Else if(not(worksheets("RawPayrollDump").cells(2,1).value="")) then 'go to next cell
End If
Next
End Sub
To find the last row of data, use the End(xlUp) function.
Try this code. It replaces all empty cells in column A with Administration.
Sub ElseIfi()
Set ws = Worksheets("RawPayrollDump")
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row ' last data row
For i = 2 To lastrow ' all rows until last data row
If ws.Cells(i, 1).Value = "" Then ' column A, check if blank
ws.Cells(i, 1).Value = "Administration" ' set text
End If
Next
End Sub
There is no need to loop. Please try this code.
Sub FillBlanks()
Dim Rng As Range
With Worksheets("RawPayrollDump")
Set Rng = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
On Error Resume Next
Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
If Err Then
MsgBox "There are no blank cells" & vbCr & _
"in the specified range.", _
vbInformation, "Range " & Rng.Address(0, 0)
Else
Rng.Value = "Administration"
End If
End Sub
Replace Blanks feat. CurrentRegion
Range.CurrentRegion
Since OP asked for "... stop looping at the end of the data set. ",
I've written this CurrentRegion version.
As I understand it, the end of the data set doesn't mean that there
cannot be blank cells below the last cell containing data in column
A.
Use the 1st Sub to test the 2nd, the main Sub (replaceBlanks).
Adjust the constants including the workbook (in the 1st Sub) to fit your needs.
Criteria is declared as Variant to allow other data types not just strings.
The Code
Option Explicit
Sub testReplaceBlanks()
Const wsName As String = "RawPayrollDump"
Const FirstCellAddress As String = "A2"
Const Criteria As Variant = "Administration"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
replaceBlanks ws, FirstCellAddress, Criteria
End Sub
Sub replaceBlanks(Sheet As Worksheet, _
FirstCellAddress As String, _
Criteria As Variant)
' Define column range.
Dim ColumnRange As Range
Set ColumnRange = Intersect(Sheet.Range(FirstCellAddress).CurrentRegion, _
Sheet.Columns(Sheet.Range(FirstCellAddress) _
.Column))
' To remove the possibly included cells above the first cell:
Set ColumnRange = Sheet.Range(Range(FirstCellAddress), _
ColumnRange.Cells(ColumnRange.Cells.Count))
' Note that you can also use the addresses instead of the cell range
' objects in the previous line...
'Set ColumnRange = sheet.Range(FirstCellAddress, _
ColumnRange.Cells(ColumnRange.Cells.Count) _
.Address)
' or a mixture of them.
' Write values from column range to array.
Dim Data As Variant
If ColumnRange.Cells.Count > 1 Then
Data = ColumnRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = ColumnRange.Value
End If
' Modify array.
Dim i As Long, k As Long
For i = 1 To UBound(Data)
If IsEmpty(Data(i, 1)) Then Data(i, 1) = Criteria: k = k + 1
Next i
' Write modified array to column range.
' The following line is used when only the first cell is known...
'Sheet.Range(FirstCellAddress).Resize(UBound(Data)).Value = Data
' ...but since the range is known and is the same size as the array,
' the following will do:
ColumnRange.Value = Data
' Inform user.
If k > 0 Then GoSub Success Else GoSub Fail
Exit Sub
' Subroutines
Success:
MsgBox "Wrote '" & Criteria & "' to " & k & " previously " _
& "empty cell(s) in range '" & ColumnRange.Address & "'.", _
vbInformation, "Success"
Return
Fail:
MsgBox "No empty cells in range '" & ColumnRange.Address & "'.", _
vbExclamation, "Nothing Written"
Return
End Sub
How do I get the position of the last non-empty cell in a filtered column without dropping the applied Autofilter? I understand it's easy to get the number of the last visible row with
Dim ws as Worksheet, rng As Range
Set rng = Range(Letter & 1 & ":" & Letter & 1) ' where Letter is the letter code of the column
GetLastVisibleRow = ws.Range(Split(ws.Cells(, rng.Column).Address, "$")(1) & ws.Rows.count).End(xlUp).row
but I need the number of the last filled row instead. At the same time, I'd like to avoid setting
ws.AutoFilterMode = False
if it's possible.
Thanks in advance.
Probably not the most efficient or fastest method, but this appears to work:
Function GetLastCellOfColumn(ColLetter As String) As Range
Dim Col As Range
Dim Rw As Long
Set Col = Range(ColLetter & ":" & ColLetter)
Set GetLastCellOfColumn = Intersect(ActiveSheet.UsedRange, Col)
For Rw = GetLastCellOfColumn.Cells.Count To 1 Step -1
If Len(GetLastCellOfColumn.Cells(Rw).Value) > 0 Then
Set GetLastCellOfColumn = GetLastCellOfColumn.Cells(Rw)
Exit Function
End If
Next
End Function
A charming solution by #jkpieterse plus a useful comment by #BigBen is exactly what I was looking for. Just to finalize the thread, the function returning the row number is
Function GetLastFilledCellOfColumn(ws As Worksheet, ColLetter As String) As Long
Dim Col As Range, Urng As Range, Rw As Long
Set Col = ws.Range(ColLetter & ":" & ColLetter)
Set Urng = Intersect(ws.UsedRange, Col)
For Rw = Urng.Cells.count To 1 Step -1
If Not IsEmpty(Urng.Cells(Rw)) Then
GetLastFilledCellOfColumn = Rw
Exit Function
End If
Next
End Function
Problem solved.
So maybe this is an alternative way to look into:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("_FilterDatabase").Columns(col)
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I'm afraid I rushed this a little and might have made a mistake but will have to get going. Hopefully you understand whats going on =)
Edit:
The above would definately work, but as figured out through the chat, there is actually a ListObject involved, called Table1, which throws of the AutoFilter range. So here are two alternative ways of doing the same thing:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("Table1")
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
Or, when you don't know the name of the table:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .ListObjects(1).Range
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I am stuck with a problem i cannot get my head around currently.
I have a checklist that has to update automatically when adding lines to my excel worksheet so that the checklist is applied to all rows.
I tried to use a "for loop" to modify the formula but excel returns Error 1004, when starting the string with "=".
No error but no functionality as well:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "Wenn(Oder(AB" & firstRow & "=""x"""
Returns error 1004:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "=Wenn(Oder(AB" & firstRow & "=""x"""
My first solution
Loop FormulaR1C1, or Formula and use nothing but english Function names eg. sum() instead of Summe() and follow english syntax , instead of ;.
Problem
When testing the syntax without a loop and actual indices it works like a charm. As soon as I try to loop it, Excel does not recognize R[i]C as cell anymore but just returns plain text.
no issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[1]C = ""x"""
issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[i]C = ""x"""
Splitting it like this did not solve my problem either
..R[" & i & "]C =..
Any tips?
// For i= ... to .. next i
// Excel 2007
Try this:
With ActiveWorkbook.Sheets("Kalkulation Änderungen")
'find last row of column AB
LastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row
'apply the formula from AB9 to its last non-blank row
.Range("AB9:AB" & LastRow).Formula = "IF(OR( R[1]C = ""x"""
End With
#UGP: that is what i thought the code might look like after implementing your tips with intersect etc.
What do you think of it, I guess you might not like the loops too much?
Typical beginner approach to loop everything?
I would have to do this for every column accordingly?
If so it would be wise to create a sub () for every column with an exit condition so that i save computing time?
Unless it is possible to hand over the columnadress to the sub_worksheet_change()?
Private Sub Worksheet_Change(ByVal Target As Range, selected_column)
_
_
_
_
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim check As Boolean
frstRow = 1
lastRow = 1
i = 1
'Rowcount
Do Until firstRow <> 1 And lastRow <> 1
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("D" & i) = "Länge" Then
firstRow = i + 2
i = i + 1
End If
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("G" & i) = "Gesamt-h" Then
lastRow = i - 2
End If
i = i + 1
Loop
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & firstRow, "AI" & lastRow)
check = False
i = firstRow
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Do While i <= lastRow And check = False
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB" & i).Value = "x" Then
check = True
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = "x"
ElseIf i = lastRow And check = False Then
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = " "
End If
i = i + 1
Loop
End If
End Sub
Here's the code. It has to be in the corresponding worksheet in the VBA-Editor.
It activates when a cell in Range(A10:A20) has been changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A10:A20")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Count = 1 Then
If Target.Value = "x" Then
'Your Code
'i.e
MsgBox (Target.Address & "has been changed")
End If
Else
MsgBox ("Please No Copy Pasterino")
End If
End If
End Sub
EDIT:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim fRow As Long, lRow As Long
Dim check As Boolean
Dim sht As Worksheet
Dim Cell As Range
Set sht = Worksheets("Tabelle1")
'Rowcount
fRow = 2
lRow = sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & fRow & ":AI" & lRow)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
For Each Cell In Range(Cells(fRow, Target.Column), Cells(lRow, Target.Column))
If Cell.Value = "x" Then
sht.Cells(9, Target.Column).Value = "x"
Exit For
Else
sht.Cells(9, Target.Column).Value = ""
End If
Next
End If
End Sub
My sheet look like :
I have a function to get index of the LAST empty cell in column A:
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
This function works to write on second array (Type2).
But now, i would like a function to get index of the FIRST empty cell in column A. So i went to this website: Select first empty cell and i tried to adapt code but it's doesn't work:
If Array= "Type1" Then
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(1).Cells
If IsEmpty(cell) = True Then NextRow = cell: Exit For 'ERROR 1004
Next cell
End If
If Array= "Type2" Then 'It s works
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
End If
ActiveSheet.Range("A" & NextRow) = "TEST"
Could you help me to adapt my code to have NextRow = IndexOf FIRST empty cell in A ?
You could just use the same method you did to get the last one.
NextRow = Range("A1").End(xlDown).Row + 1
I do this and it' works:
If Array= "Type1" Then
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(1).Cells
If IsEmpty(cell) = True Then
NextRow = cell.Row
Exit For
MsgBox NextRow
End If
Next cell
End If
If Array= "Type2" Then 'It s works
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
End If
ActiveSheet.Range("A" & NextRow) = "TEST"
You should look bottom up for this.
And Find is better than xlUp.
Sub FindBlank()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = ActiveSheet
Set rng1 = ws.Columns(1).Find("*", ws.[a1], xlFormulas, , xlByColumns, xlPrevious)
If Not rng1 Is Nothing Then
MsgBox "Last used cell is " & rng1.Address(0, 0)
Else
MsgBox ws.Name & " row1 is completely empty", vbCritical
End If
End Sub
I took a similar approach to some of the answers, but with the goal of repeatedly looking down the column until I could guarantee that there was no more populated cells below.
I turned this into a small function that I put in a standard module:-
Public Function getFirstBlankRowNumberOnSheet(sht As Worksheet, Optional startingRef As String = "A1") As Long 'may get more than 32767 rows in a spreadsheet (but probably not!)
Dim celTop As Range
Dim celBottom As Range
On Error Resume Next
Set celTop = sht.Range(startingRef)
Do
Set celBottom = celTop.End(xlDown)
Set celTop = celBottom.Offset(1) 'This will throw an error when the bottom cell is on the last available row (1048576)
Loop Until IsEmpty(celBottom.value)
getFirstBlankRowNumberOnSheet = celTop.Row
End Function
This will throw an error if there happens to be content in the row #1048576! The particulars of this are dependent on the Excel version I suppose in terms of maximum row cont allowed.