I have 2 wb to_update_example_1 and purchasing_list
basically what I am trying to do is to a loop row by row on workbook to_update_example_1 if the same name is found to copy the a variable to the purchasing_list workbook.
However it keeps giving me error 91 at the searching portion and I would need an advice how do I write vVal2(which is the Qty) to Purchasing list workbook the column is just beside the found name so I tried to use active cell offset but didn't work too
any advice is appreciated thanks
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Integer
Dim vVal1, vVal2 As String
Numrows = Range("A1", Range("A1").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
Range("A1").Select ' Select cell a2.
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times.
vVal1 = Cells(x, 8)
vVal2 = Cells(x, 7)
Windows("Purchasing List.xls").Activate
ActiveSheet.Cells.Find(What:=vVal1, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
''write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
Windows("To_update_example_1.xlsm").Activate
''''''''ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
When using the Find function, it's recommended if you set a Range object to the Find result, and also prepare your code for a scenario that Find didn't find vVal1 in "Purchasing List.xls" workbook. You can achieve it by using the following line If Not FindRng Is Nothing Then.
Note: avoid using Select, Activate and ActiveSheet, instead fully qualify all your Objects - see in my code below (with comments).
Modified Code
Option Explicit
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Long, Numrows As Long
Dim vVal1 As String, vVal2 As String
Dim PurchaseWb As Workbook
Dim ToUpdateWb As Workbook
Dim FindRng As Range
' set workbook object of "Purchasing List" excel workbook
Set PurchaseWb = Workbooks("Purchasing List.xls")
' set workbook object of "To_update_example_1" excel workbook
Set ToUpdateWb = Workbooks("To_update_example_1.xlsm")
With ToUpdateWb.Sheets("Sheet1") ' <-- I think you are trying to loop on "To_update_example_1.xlsm" file , '<-- change "Sheet1" to your sheet's name
' Set numrows = number of rows of data.
Numrows = .Range("A1").End(xlDown).Row
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times
vVal1 = .Cells(x, 8)
vVal2 = .Cells(x, 7)
' change "Sheet2" to your sheet's name in "Purchasing List.xls" file where you are looking for vVal1
Set FindRng = PurchaseWb.Sheets("Sheet2").Cells.Find(What:=vVal1, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
If Not FindRng Is Nothing Then '<-- make sure Find was successful finding vVal1
' write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
' Not sure eactly what you want to do now ???
Else ' raise some kind of notification
MsgBox "Unable to find " & vVal1, vbInformation
End If
Next x
End With
Application.ScreenUpdating = True
End Sub
Edited to account for OP's comment about where to search and write values
ShaiRado already told you where the flaw was
here's an alternative code
Option Explicit
Sub Macro1()
Dim cell As Range, FindRng As Range
Dim purchListSht As Worksheet
Set purchListSht = Workbooks("Purchasing List.xls").Worksheets("purchaseData") '(change "purchaseData" to your actual "purchase" sheet name)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Workbooks("to_update_example_1").Sheets("SourceData") ' reference your "source" worksheet in "source" workbook (change "SourceData" to your actual "source" sheet name)
For Each cell In .Range("H1", .Cells(.Rows.Count, 8).End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced "source" sheet column "H" not empty cells
Set FindRng = purchListSht.Columns("G").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns) ' try finding current cell content in "purchase" sheet column "G"
If Not FindRng Is Nothing Then FindRng.Offset(, -2).Value = cell.Offset(, -1).Value ' if successful, write the value of the cell one column left of the current cell to the cell two columns to the left of found cell
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
I am a bit stuck and hoping to find some help. I have some experience in VBA but this particular problem exceeds my programming knowledge.
I have a sheet with 1000 - 1250 rows of data, and anywhere from 20 - 60 columns that can change monthly.
What I am hoping to do is look at each cell for an X, and when found it will create a new line on a separate tab. The line would contain the first cell in the row where the X was found and the column header from the column the X was found in.
I have been able to write some things that will find the X's in the sheet, create new items on another page and the like, but I can't get one script to do everything I need.
This is an example of the data structure:
Data
Expected result:
Output
Sorry for the links, I am too new to post photos.
Any help on how this can be achieved, documents, tips or the like would be super helpful and most appreciated. Thank you for looking!
Andrew
EDIT:
Some of the code I have put together:
Dim uSht As String
Dim wsExists As Boolean
Dim lRow As Long
Dim lcol As Long
Dim ws As Worksheet
Sub CopyData()
'Setup Sheetnames
uSht = "UPLOAD"
uTem = "TEMPLATE"
' Stop flicker
Application.ScreenUpdating = False
' Check for Upload Worksheet
WorksheetExists (uSht)
'MsgBox (wsExists)
If wsExists = False Then
' If it does not exist, create it
Call CreateSheet("UPLOAD")
End If
'Setup stuff
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets(uTem)
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(uSht)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox (lRow)
'MsgBox (lCol)
Range(Cells(lRow, lColumn)).Select
Application.ScreenUpdating = True
End Sub
Sub CreateSheet(wsName)
'Creates the uSht worksheet
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = uSht
End With
End Sub
Function WorksheetExists(wsName As String) As Boolean
'Check to see if uSht exists and return.
wsName = UCase(wsName)
For Each ws In ThisWorkbook.Sheets
If UCase(ws.Name) = wsName Then
wsExists = True
Exit For
End If
Next
WorksheetExists = wsExists
End Function
Using FindAll from here: Extracting specific cells from multiple Excel files and compile it into one Excel file
(but change LookAt:=xlPart to LookAt:=xlWhole)
Rough outline:
Dim col, c, dest As Range
Set dest = sheets("results").Range("A2")
Set col = FindAll(sheets("data").range("a1").currentregion, "X")
For each c in col
dest.resize(1,2).value = array(c.entirerow.cells(1).value, _
c.entirecolumn.cells(1).value)
set dest = dest.offset(1, 0)
next
You need a Find/FindNext loop that will locate all X values in the first worksheet. After a found cell is located, the cell's row and column can be used to identify the location and project.
Option Explicit
Sub Macro1()
Dim addr As String, loc As String, pro As String
Dim ws2 As Worksheet, fnd As Range
Set ws2 = Worksheets("sheet2")
With Worksheets("sheet1")
Set fnd = .Cells.Find(What:="x", after:=.Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fnd Is Nothing Then
addr = fnd.Address(0, 0)
Do
loc = .Cells(fnd.Row, "A").Value
pro = .Cells(1, fnd.Column).Value
With ws2
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = loc
.Cells(.Rows.Count, "A").End(xlUp).Offset(0, 1) = pro
End With
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address(0, 0)
End If
End With
End Sub
I want to import values from a dynamic worksheet to our "Database" sorted by the title of the column. As you can see I have scraped together something that works, but it is very slow and doesn't copy just the values.
The first row of the sheet is the titles, the second and further down rows are the values I want to copy.
Sub Copypasta()
Sheets("copypasta").Select
Sheets("copypasta").Range("A2").Activate
While Not ActiveSheet.Cells(1, ActiveCell.Column) = ""
t1 = ActiveSheet.Cells(1, ActiveCell.Column)
Selection.Copy
Set MyActiveCell = ActiveCell
Sheets("Database").Activate
lnCol = Sheets("Database").Cells(1, 1).EntireRow.Find(What:=t1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
lnRow = Sheets("Database").Range("a65536").End(xlUp).Row
If lnCol > 1 Then Sheets("Database").Cells(lnRow, lnCol).Activate Else Sheets("Database").Cells(lnRow, lnCol).Offset(1, 0).Activate
ActiveSheet.Paste 'xlPasteValues
Sheets("copypasta").Activate
MyActiveCell.Offset(0, 1).Activate
Wend
End Sub
I tried to use PasteSpecial xlPasteValues or setting the value of the cell directly, but I can't get it to work. I am googling every error it throws and then search the code for where the error occurs.
Try the code below:
Option Explicit
Sub Copypasta()
Dim CopySht As Worksheet
Dim DBSht As Worksheet
Dim i As Long, lnCol As Long, lnRow As Long
Dim MyActiveCell As Range, FindRng As Range
Dim t1
' set the Worksheet objects
Set CopySht = ThisWorkbook.Sheets("copypasta")
Set DBSht = ThisWorkbook.Sheets("Database")
' set the anchor position on the loop
Set MyActiveCell = CopySht.Range("A2")
' loop through columns at the first row (until you reach a column that is empty)
While CopySht.Cells(1, MyActiveCell.Column) <> ""
t1 = CopySht.Cells(1, MyActiveCell.Column)
MyActiveCell.Copy
With DBSht
lnRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' find last row with data in Column "A"
Set FindRng = .Rows(1).Find(What:=t1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not FindRng Is Nothing Then ' check if Find was successful
lnCol = FindRng.Column
Else
lnCol = 1
End If
' there's no need to use Select and Activate to Copy and/or Paste
.Cells(lnRow + 1, lnCol).PasteSpecial xlPasteValues
End With
Set MyActiveCell = MyActiveCell.Offset(0, 1) ' loop one column to the right
Wend
End Sub
I have a wordbook with multiple sheets. I have a sheet called “Info” that contains hundreds of rows of employees. Each employee is assigned an employee number in column B; the remainder of the row (24 columns) contains the rest of the employee’s personal information).
I have another sheet called “data” that only requires a group of 20 to 40 people that can vary from day to day
I want to be able to enter an employee number (ex: SN124523) into an empty cell in column B on Sheet called “Data”. I would then like the remainder of the row to self-populate with the employee information from the “Info” sheet.
I need to do this with up to 40 employees, so regardless of which cell I select in column B on the “Data” sheet I would like it to search the “info “sheet on import the information.
I have made this work with a VLOOKUP formula, but because multiple people sometimes use this book and I sometime have to delete and replace the "info" Sheet That I always end up with a #REF error in the formulas.
I tried something like this for just a few lines of data as a trial but I can’t get anything to work.
Sub Add_member()
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim iRow, row_count As Long
Set ws = Worksheets("Info")
Set ws1 = Worksheets("Data")
row_count = ws.Range("B" & Rows.Count).End(xlUp).Row
For iRow = 2 To row_count
If ws1.Cells(iRow, 2) = ws.Cells(iRow, 2) Then
ws1.Cells(iRow, 4).Value = ws.Cells(iRow, 4).Value
ws1.Cells(iRow, 5).Value = ws.Cells(iRow, 5).Value
‘ I would need this to fill 24 columns in total.
End If
Next
End Sub
Any help Much Appreciated.
I would use an Event_Handler in this situation. Therefore when you enter the number the data is automatically updated for you.
Assuming B1 is the cell you will be entering the number to be looked up.
Post the below code into the WorkSheet module, enter a number and the data should appear for that number in row 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fCell As Range
Dim rng As Range
Application.EnableEvents = 0
Set ws = Worksheets("Info")
If Not Intersect(Target, Range("B1")) Is Nothing Then
Set fCell = ws.Range("B2:B1000").Find(What:=Target, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fCell Is Nothing Then
Target.Resize(, 24).Value = fCell.Resize(, 24).Value
Else
MsgBox "No number exists."
Range("B1:Y1").ClearContents
End If
End If
Application.EnableEvents = 1
End Sub
assuming
employee number is a string (like "SN124523")
there's always one employee number at least
employee numbers are input in a contiguous range in sheet "data" column B (i.e. n blanks between them)
then you could use
Sub Add_member()
Worksheets("Data").Columns(2).SpecialCells(xlCellTypeConstants, xlTextValues).offset(, 2).Resize(, 24).FormulaR1C1 = "=Vlookup(RC2,Info!C2:C27,column()-1)"
End Sub
or, should you want to get rid of formulas:
Sub Add_member()
With Worksheets("Data").Columns(2).SpecialCells(xlCellTypeConstants, xlTextValues).offset(, 2).Resize(, 24)
.FormulaR1C1 = "=Vlookup(RC2,Info!C2:C27,column()-1)"
.value = .value
End With
End Sub
of course all the above assumptions can be removed and the code changed accordingly.
but the one above just to show the shortest possible
Untested:
Sub Add_member()
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim f As Range, c As Range, rng As Range
Set ws = Worksheets("Info")
Set ws1 = Worksheets("Data")
Set rng = ws1.Range("B2", ws1.Cells(Rows.Count, 2).End(xlUp))
For Each c In rng.Cells
If Len(c.Value) > 0 Then
Set f = ws.Columns(2).Find(what:=c.Value, LookIn:=xlValues, _
lookat:=xlWhole)
If Not f Is Nothing Then
c.Offset(0, 2).Resize(1, 24).Value = _
f.Offset(0, 2).Resize(1, 24).Value
End If
End If
Next
End Sub
The code below basically searches for any keyword in any sheet and highlights it. My question is, how to also copy the entire row number where the word/words is/are found to a new sheet in addition to the highlight?
Is it also possible to precise in which worksheet the search will be done?
Many thanks in advance,
Gonzalo
Sub CheckMULTIVALUE()
'This macro searches the entire workbook for any cells containing the text "#MULTIVALUE" and if found _
highlight the cell(s) in yellow. Once the process has completed a message box will appear confirming completion.
Dim i As Long
Dim Fnd As String
Dim fCell As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Fnd = InputBox("Find what:", "Find and Highlight", "#MULTIVALUE")
If Fnd = "" Then Exit Sub
For Each ws In Worksheets
With ws
Set fCell = .Range("A1")
For i = 1 To WorksheetFunction.CountIf(.Cells, Fnd)
Set fCell = .Cells.Find(What:=Fnd, After:=fCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If fCell Is Nothing Then
MsgBox Fnd & " not on sheet !!"
Exit For
Else
With fCell
.Interior.ColorIndex = 6
End With
End If
Next i
End With
Next ws
Application.ScreenUpdating = True
MsgBox "Check complete"
End Sub
Add code before the For loop to create the results worksheet or clear it if it already exists:
Dim results As Worksheet: Set results = ActiveWorkbook.Sheets("Results")
If results Is Nothing Then
Set results = ActiveWorkbook.Sheets.Add()
results.Name = "Results"
Else
results.Cells.Clear
End If
Create a reference to its A1 cell and a counter:
Dim resultsRange As Range: Set resultsRange = results.Range("A1")
Dim matches As Long
When you find a match add what you need to the Results worksheet and increment the counter.
With fCell
.Interior.ColorIndex = 6
resultsRange.Offset(matches, 0).Value = fCell.Row
resultsRange.Offset(matches, 1).Value = fCell.Value
matches = matches + 1
End With
To specify a specific sheet remove For Each ws In Worksheets and Next ws and replace With ws with With ActiveWorkbook.Sheets("SheetNameHere")
i need some help as i am experienceing a problem, pretty new to VBA. i want to copy that data from L5-L18, excluding some cells and paste it to column B of sheet(In) and create a button that every time i push it to copy the data from column B ,sheet(Data) to the sheet(in) and move columnto the right. like first time column b, next time column c...every time i push the button.. much appreciated
Sub Macro2()
Sheets("Data").Select
Range("L5,L6,L7,L8,L9,L10,L13,L14,L15,L16,L17,L18").Select
Range("L18").Activate
Selection.Copy
Sheets("In").Select
Range("B5").Select
ActiveSheet.Paste
Range("B5").Offset(0, 1).Select
End Sub
Method A
To insert into column B and shift everything else to the right try this:
Sub offsetCol()
Dim wksData As Worksheet
Set wksData = Sheets("Data")
Dim wksIn As Worksheet
Set wksIn = Sheets("In")
Application.CutCopyMode = False
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wksIn.Range("B5:B10").Value = wksData.Range("L5:L10").Value
wksIn.Range("B11:B16").Value = wksData.Range("L13:L18").Value
End Sub
Method B
Find last column in sheet and tack on information to next available:
Sub offsetCol()
Dim wksData As Worksheet
Set wksData = Sheets("Data")
Dim wksIn As Worksheet
Set wksIn = Sheets("In")
Set rLastCell = wksIn.Cells.Find(What:="*", After:=wksIn.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
wksIn.Range(Cells(5, rLastCell.Column + 1), Cells(10, rLastCell.Column + 1)).Value = wksData.Range("L5:L10").Value
wksIn.Range(Cells(11, rLastCell.Column + 1), Cells(16, rLastCell.Column + 1)).Value = wksData.Range("L13:L18").Value
End Sub
Method C
Find last column in row 5 and tack on info in next available column:
Sub offsetCol()
Dim wksData As Worksheet
Set wksData = Sheets("Data")
Dim wksIn As Worksheet
Set wksIn = Sheets("In")
Dim rLastCol As Integer
rLastCol = wksIn.Cells(5, wksIn.Columns.Count).End(xlToLeft).Column + 1
wksIn.Range(Cells(5, rLastCol), Cells(10, rLastCol)).Value = wksData.Range("L5:L10").Value
wksIn.Range(Cells(11, rLastCol), Cells(16, rLastCol)).Value = wksData.Range("L13:L18").Value
End Sub
Starting Data:
Results (Method C):
Part of the question - copy from location A to location B, is not very clear, but I am guessing this is what you need. Put this under a macro of a button:
Sub Macro2()
Dim rng As Range
Sheets("IN").Range("B:B").Insert Shift:=xlToRight
Sheets("Data").Select
Set rng = Range("L5,L6,L7,L8,L9,L10,L13,L14,L15,L16,L17,L18")
rng.Copy Sheets("IN").Range("B:B")
End Sub