Could someone help me please - I've got one worksheet, and on an entry of a code I need it to pull through certain set cells from that row and display them on the active sheet.
This is as far as I've got and might give some idea of how ignorant I am in the way of VBA, and it doesn't work.
Sub AddProduct()
On Error GoTo MyErrorHandler:
Dim Code As Long
Code = B4
Sheets("Code Input Sheet").Range(A9) = Application.VLookup(Code,Worksheets("Cost Sheet").Range("A2:XFD1048576"), 1, False)
ActiveCell.End(xlRight).Offset(0, 1).Select
Selection = Application.VLookup(Code, Worksheets("Cost Sheet").Range("A2:XFD1048576"), 2, False)
ActiveCell.End(xlRight).Offset(0, 1).Select
Selection = Application.VLookup(Code, Worksheets("Cost Sheet").Range("A2:XFD1048576"), 5, False)
ActiveCell.End(xlDown).Offset(1, 0).Select
MyErrorHandler:
If Err.Number = 1004 Then
MsgBox "Code doesn't exist."
End If
End Sub
Hopefully this makes sense
Thanks
EDIT
I probably need to start from scratch, but here's basically what I need: The user to enter a code in B4, runs the macro through the button which looks up on the second Sheet if it exists, and pulls through three cells from that code's row to A9:C9 on the first sheet. Then hopefully the process can be repeated with the data going to the next row below. Hopefully this isn't too much of an ask!
Instead of the VLOOKUP use the Range.Find method:
Sub AddProduct()
Dim code As Variant
Dim c As Range
Dim ws As Worksheet
Dim lastrow As Long
Set ws = ActiveSheet
code = ws.Range("B4")
'Find code and set c to the cell
Set c = Worksheets("Cost Sheet").Range("A:A").Find(code)
If c is Nothing Then
'if the code is not found
MsgBox "Not Found"
Exit Sub
Else
'this finds the next empty row
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
ws.Range("A" & lastrow) = c
ws.Range("B" & lastrow) = c.Offset(, 1)
ws.Range("C" & lastrow) = c.Offset(, 4)
End If
End Sub
Related
I have a worksheet that has multiple value and what I would like to do is search say column "B" for a value and when it finds it to copy the complete row and paste it somewhere else. I have a similar function to do this but it stops after it finds the first one which is fine for the situation that I am using it in but for this case I need it to copy all that match. below is the code that im using at the moment that only gives me one value
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.value
lastRow = wks1.range("A" & Rows.Count).End(xlUp).row
Set rangeList = wks1.range("A2:A" & lastRow)
On Error Resume Next
row = Application.WorksheetFunction.Match(strSelect, wks1.Columns(1), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
Thanks
I would suggest to load data into array first and then operate on this array instead of operating on cells and using Worksheet functions.
'(...)
Dim data As Variant
Dim i As Long
'(...)
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.Value
lastRow = wks1.Range("A" & Rows.Count).End(xlUp).Row
'Load data to array instead of operating on worksheet cells directly - it will improve performance.
data = wks1.Range("A2:A" & lastRow)
'Iterate through all the values loaded in this array ...
For i = LBound(data, 1) To UBound(data, 1)
'... and check if they are equal to string [strSelect].
If data(i, 1) = strSelect Then
'Row i is match, put the code here to copy it to the new destination.
End If
Next i
End If
I have used the Range.Find() method to search each row. For each row of data which it finds, where the value you enter matches the value in column G, it will copy this data to Sheet2. You will need to amend the Sheet variable names.
Option Explicit
Sub copyAll()
Dim rngFound As Range, destSheet As Worksheet, findSheet As Worksheet, wb As Workbook
Dim strSelect As String, firstFind As String
Set wb = ThisWorkbook
Set findSheet = wb.Sheets("Sheet1")
Set destSheet = wb.Sheets("Sheet2")
strSelect = ExpIDComboBox.Value
Application.ScreenUpdating = False
With findSheet
Set rngFound = .Columns(7).Find(strSelect, LookIn:=xlValues)
If Not rngFound Is Nothing Then
firstFind = rngFound.Address
Do
.Range(.Cells(rngFound.Row, 1), .Cells(rngFound.Row, _
.Cells(rngFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy
destSheet.Cells(destSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
Set rngFound = .Columns(2).Find(strSelect, LookIn:=xlValues, After:=.Range(rngFound.Address))
Loop While firstFind <> rngFound.Address
End If
End With
Application.ScreenUpdating = True
End Sub
I've assumed you will have data between columns A:G?
Otherwise you can just amend the .Copy and .PasteSpecial methods to fit your requirements.
Thanks for your replys. I tired to use both methods but for some reason they did not seem to work. They did not give me an error they just did not produce anything.#mielk I understand what you mean about using an array to do this and it will be a lot faster and more efficent but I dont have enfough VBA knowledge to debug as to why it did not work. I tried other methods and finally got it working and thought it might be usefull in the future for anybody else trying to get this to work. Thanks once again for your answers :)
Private Sub SearchButton2_Click()
Dim domainRange As range, listRange As range, selectedString As String, lastRow As Long, ws, wks3 As Excel.Worksheet, row, i As Long
Set wks3 = Worksheets("Exceptions") '<----- WorkSheet for getting exceptions
If DomainComboBox.ListIndex <> -1 Then '<----- check that a domain has been selected
selectedString = DomainComboBox.value
lastRow = wks3.range("A" & Rows.Count).End(xlUp).row ' finds the last full row
Set listRange = wks3.range("G2:G" & lastRow) 'sets the range from the top to the last row to search
i = 2
'used to only create a new sheet is something is found
On Error Resume Next
row = Application.WorksheetFunction.Match(selectedString, wks3.Columns(7), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
For Each ws In Sheets
Application.DisplayAlerts = False
If (ws.Name = "Search Results") Then ws.Delete 'deletes any worksheet called search results
Next
Application.DisplayAlerts = True
Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'makes a new sheet at the end of all current sheets
ws.Name = "Search Results" 'renames the worksheet to search results
wks3.Rows(1).EntireRow.Copy 'copys the headers from the exceptions page
ws.Paste (ws.Cells(, 1)) 'pastes the row into the search results page
For Each domainRange In listRange ' goes through every value in worksheet trying to match what has been selected
If domainRange.value = selectedString Then
wks3.Rows(i).EntireRow.Copy ' copys the row that results was found in
emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 ' finds next empty row
ws.Paste (ws.Cells(emptyRow, 1)) 'pastes the contents
End If
i = i + 1 'moves onto the next row
ws.range("A1:Q2").Columns.AutoFit 'auto fit the columns width depending on what is in the a1 to q1 cell
ws.range("A1:Q1").Cells.Interior.ColorIndex = (37) 'fills the header with a colour
Application.CutCopyMode = False 'closes the paste funtion to stop manual pasting
Next domainRange ' goes to next value
Else
MsgBox "No Results", vbInformation, "No Results" 'display messgae box if nothing is found
Exit Sub
End If
End If
End Sub
Thanks.
N.B. this is not the most efficent way of doing this read mielk's answer and the other answer as they are better if you can get them working.
I'd like to make a summary sheet that, if changed, changes the source sheets it is pulling from. The code I have so far aggregates all of my sheets on the summary sheet on the summary sheet's activation event. I am trying to have all of my other sheets updated on the deactivation event but it does not seem to be working. Here is the code I am working with:
Private Sub Worksheet_Deactivate()
Application.ScreenUpdating = False
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 1 To UBound(tabs)
Sheets(tabs(j)).Select
Dim rng1 As Range
Dim Stri As String
For i = 3 To ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row
Stri = ActiveSheet.Cells(i, "A")
Set rng1 = Worksheets("Summary").Range("A:A").Find(Stri, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets("Summary").Range(rng1.Address).EntireRow.Copy
ActiveSheet.Range("A" & i).EntireRow.Select
Selection.Insert Shift:=xlLeft
ActiveSheet.Range("A" & i + 1).EntireRow.Select
Selection.Delete Shift:=xlUp
Else
MsgBox strSearch & " not found"
End If
Next
ActiveSheet.Range("A" & 1).Select
Next
Application.ScreenUpdating = True
End Sub
I am very new to vba and this is my first post on stackoverflow so if I missed anything just let me know.
When you assign a variant array in that manner, you will end up with a zero-based array. You need to start at j = 0. As your own code currently is, it will never access the BELD worksheet.
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 0 To UBound(tabs)
....
A more universal method would be using For j = LBound(tabs) To UBound(tabs) which does not matter whether your array is 1 or 0 based as you let each array describe its own properties through the LBound function and UBound function.
A more comprehensive rewrite of your routine would include getting rid of the .Select and .Activate methods and use direct worksheet and cell referencing in its place.
Private Sub Worksheet_Deactivate()
Dim rng1 As Range
Dim Stri As String, lr As Long, j As Long, i As Long
Dim tabs As Variant
On Error GoTo bm_Safe_exit
Application.ScreenUpdating = False
Application.EnableEvents = False
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", _
"AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = LBound(tabs) To UBound(tabs)
With Sheets(tabs(j))
lr = .Cells.Find(Chr(42), After:=.Cells(1, 1), SearchDirection:=xlPrevious).Row
For i = 3 To lr
Stri = .Cells(i, "A").Value
If CBool(Len(Stri)) Then
On Error Resume Next
With Me.Range("A:A")
Set rng1 = .Find(What:=Stri, After:=.Cells(.Rows.Count), LookIn:=xlValues, LookAt:=xlWhole)
End With
On Error GoTo bm_Safe_exit
If Not rng1 Is Nothing Then
'clearing then copy/paste may be better than inserting, pasting and ultimately deleting old row
.Rows(i).Clear
rng1.EntireRow.Copy _
Destination:=.Range("A" & i)
Else
'maybe copy the data from the sheet back to the summary sheet if this occurs
MsgBox Stri & " on " & .Name & " not found on Summary"
End If
End If
Next
End With
Next
bm_Safe_exit:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Since this is in the Summary worksheet's code sheets, the use of Me can be applied to the Summary worksheet object. Once you have set rng1 to the range returned by the find, it is no longer necessary to describe the worksheet it comes from as its Range .Parent property is carried with it.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With
I need your help with conditional Vlookup. I found a code that works fine if there is vlookup value in the source data but it fails once there is a missing value. Also I need to add a condition ('If the value is found by Lookup, then return "Old" (from 2nd column in vlookup table)
'If the value is NOT found, then return "New" (just text which is not coming from vlookup table). Could you help me?
Thank you,'Russ
Sub Vlookup_Condition()
Dim rng As Range
Dim i As Long
With ActiveSheet.Cells
Set rng = .Range("A1:A" & .Cells(.Rows.count, 1).End(xlUp).row)
For i = 2 To rng.Rows.count
'If the value is found by Lookup, then return "Old" (from 2nd column in vlookup table)
'If the value is NOT found, then return "New" (just text which is not coming from vlookup
'table)
rng.Cells(i, 2) = Application.WorksheetFunction.VLookup(.Cells(i, 1), Sheets("Lookuptable").Range("A:B"), 2, False)
Next
End With
End Sub
As per your puzzle. I found a solution like this Russ
UPDATED & TESTED
Sub Vlookup_Condition()
Dim rng As Range
Dim i As Long
Application.ScreenUpdating = False
Worksheets("DataFile").Activate
Range("R2").Activate
With Worksheets("DataFile").Cells
Set rng = .Range("O1:O" & .Cells(.Rows.count, 1).End(xlUp).row)
For i = 2 To rng.Rows.count
rng.Cells(i, 4) = Application.VLookup(.Cells(i, 15), Sheets("Lookuptable").Range("A:B"), 2, False)
If IsError(rng.Cells(i, 4)) Then
If rng.Cells(i, 4) = CVErr(xlErrNA) Then ' Given if condition to change it from "#NA" to "New"
rng.Cells(i, 4) = "New"
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Try this
Sub Vlookup_Condition()
Dim rng As Range
Dim ws as Worksheet
Dim i As Long
Set ws = ActiveSheet
i =2
With ws.Range("A1:A" & Rows.Count)
.Formula = "=VLookup(" & ws.Cells(2,1).Address & ",Lookuptable!$A:$B,2,false)"
End With
Do while ws.Cells(i, 1) <> ""
if ws.Cells(i,2) <> "OLD" Then ws.Cells(i,2) = "New"
i = i +1
Loop
Hope this helps there is a more concise way to do this but this way might be easier to build off of.
Ok after further review TRY THIS! lol
With ActiveSheet
Set rng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
For i = 2 to rng.Rows.Count
rng.Cells(i, 2) = Application.WorksheetFunction.VLookup(ActiveSheet.Cells(i,1), Sheets("Lookuptable").Range("A:B"), 2, False)
Next
End With
End Sub
I really hope this works for ya mate if not ill probably not do any actual work AT work tomorrow until i figure out how i totally punted this help lol
I'm trying to run a simple For loop which will be expanded to include more functionality later but having trouble as it keeps throwing an error "invalid next control variable reference". The code I am trying to use is listed below.
Sub Tickbox()
Set Location = Sheets("TickBoxSheet").Range("B:B")
i = WorksheetFunction.CountA(Location)
Sheets("TickBoxSheet").Range("B2").Select
For a = 1 To i
If Selection.Value = "True" Then
Row = Selection.Row
'Hide some rows in another sheet via if statements
ActiveCell.Offset(1, 0).Select
End If
Next i
End Sub
I don't know if I need more coffee this morning but I can't seem to figure out what the hell is going on. Any help will be greatly appreciated.
The incremented variable (in Next) should be the index variable, i.e.:
For a = 1 To i
'...
Next a
i is so popular as index that you should think twice before using it in other contexts.
You have already got your answer from llmo. However there are few other things I would like to stress upon...
Try and avoid .Select. It will slow down your code.
Also It is not necessary that WorksheetFunction.CountA(Location) will give you the last row considering that you want to loop through all the rows which have data. I suggest this
Sub Tickbox()
Dim i As Long, a As Long, Rw As Long
With Sheets("TickBoxSheet")
i = .Range("B" & .Rows.Count).End(xlUp).row
For a = 2 To i
If .Range("B" & a).Value = "True" Then
Rw = a
'Hide some rows in another sheet via if statements
End If
Next a
End With
End Sub
You can make it more fast using Autofilter as well so that you loop through cells which only have True For example
Sub Tickbox()
Dim i As Long, a As Long, Rw As Long
Dim Location As Range, acell As Range
With Sheets("TickBoxSheet")
'~~> Remove any filters
.AutoFilterMode = False
i = .Range("B" & .Rows.Count).End(xlUp).row
With .Range("B1:B" & i)
.AutoFilter Field:=1, Criteria1:="True"
Set Location = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
Debug.Print Location.Address
End With
'~~> Remove any filters
.AutoFilterMode = False
For Each acell In Location
If acell.Value = "TRUE" Then
Rw = acell.row
'Hide some rows in another sheet via if statements
End If
Next acell
End With
End Sub