I am getting error messages i that state that variable isn't defined. And VB is coloring this code red If LCase(wb.Range("Q" & i) = "y" Then .AutoFilter and I don't know why.
It's really important that only rows with a "y" in column Q in each range is pasted, and not everything else.
I had to change i to 2 To 500, and j = 2 To 20, but am worried that I might get columns that I don't want pasted into Sheet2(Materials_Estimate). I just want the range columns to be pasted.
The ranges include Sheet2 information as shown in the picture below (B=text, c=text, D=text, F=up to 3 numbers, G=a letter y, H=text, I=a calculation copied from Sheet 1 of the qty*cost)
Can anyone assist me?
[Code]
Option Explicit
Sub Estimating2()
Application.ScreenUpdating = False
'naming the workbook and worksheets and ranges
Dim ProjectBudgeting1 As Workbook
Dim Materials_Budget As Worksheet
Dim Materials_Estimate As Worksheet
Dim LowesFax As Worksheet
Dim HomeDepotFax As Worksheet
Dim SBath1 As Range
Dim SBath2 As Range
Dim SBed1 As Range
Dim SBed2 As Range
Dim SBed3 As Range
Dim SBed4 As Range
Dim SHall As Range
Dim SFP As Range
Dim SRP As Range
Dim SKit As Range
Dim SGar As Range
Dim BuyOA As Range
Dim SFlorida As Range
Dim TargetRange As Range
Dim ActiveWorksheet As Worksheet
'naming the worksheets and ranges in code
Set ProjectBudgeting1 = ActiveWorkbook
Set Materials_Budget = Worksheets("Materials_Budget")
Set Materials_Estimate = Worksheets("Materials_Estimate")
Set LowesFax = Worksheets("LowesFax")
Set HomeDepotFax = Worksheets("HomeDepotFax")
Set SBath1 = Range("Materials_Budget!Supplies_Bathroom1")
Set SBath2 = Range("Materials_Budget!Supplies_Bathroom2")
Set SBed1 = Range("Materials_Budget!Supplies_Bedroom1")
Set SBed2 = Range("Materials_Budget!Supplies_Bedroom2")
Set SBed3 = Range("Materials_Budget!Supplies_Bedroom3")
Set SBed4 = Range("Materials_Budget!Supplies_Bedroom4")
Set SHall = Range("Materials_Budget!Supplies_Hallway")
Set SFP = Range("Materials_Budget!Supplies_FrontPorch")
Set SRP = Range("Materials_Budget!Supplies_RearPorch")
Set SKit = Range("Materials_Budget!Supplies_Kitchen")
Set SGar = Range("Materials_Budget!Supplies_Garage")
Set SFlorida = Range("Materials_Budget!Supplies_Florida")
'Here I'm calling out the column q and looking for a "Y"
Set BuyOA = Range("Materials_Budget!Buy_OrderApproval")
'Here I'm naming the source of the information that gets copied into other sheets
Set ActiveWorksheet = Materials_Budget
'Here is the sheet where the source cells are pasted
Set TargetRange = Range("Materials_Estimate!EstimateTableArea1")
'Looking for the "Y" in column q for duplicating and printing corresponding rows (i) and columns (j)
For i = 12 To 520
Cells("Q", i) = "Row " & i & " Col " & j
For j = 2 To 20
If LCase(wb.Range("Q" & i) = "y" Then .AutoFilter
i = i + 1
Range("Q" & i).Select
i = i - 1
Next q
Next i
For j = 1 To 5
Cells(i, j) = "Row " & i & " Col " & j
End Sub
Application.ScreenUpdating = True
End With
End Sub
[Code/]
I see many errors.
A) You have not declared your objects. For example, you need to declare SBath1, SBath2 etc.. as Range
B) You have declared ProjectBudgeting1 as workbook but then you are using it as a worksheet object.
C) When setting range, fully qualify them
D) Your wb object is undeclared. I would strongly suggest that you use Option Explicit at the top of your code
E) You have an extra bracket ) in wb.Range("Q12:Q" & LastRow))
F) Avoid the use of .Select INTERESTING READ
G) Finally, I would highly recommend on forgetting one word in vba and that is using End to stop a code. Reason is quite simple. It's like Switching your Computer using the POWER OFF button. The End statement stops code execution abruptly. Also the Object references held (if any) by other programs are invalidated.
Here is a basic gist on how your code should look like
Sub Estimating2()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range
Set wb = ActiveWorkbook '~~> Or ThisWorkbook?
Set ws = wb.Sheets("Sheet1")
With ws
Set rng1 = .Range("Supplies_Bathroom1")
Set rng2 = .Range("Supplies_Bathroom2")
'
'~~> And so on
'
End With
End Sub
Related
I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help
I have 2 workbooks with data like this:
As seen, column A is my unique key to map the 2 workbooks. The values i want to populate are the "TBD" in the Raw file (image1). So i'm looking for key 11x in Master File and get values for column B, C & D (assembly, sub and part) for that key.
I "tried" match func but couldn't figure the destination to copy the search value and my code only returns one value at a time anyways...
for R = 2 To lastrow
y=application.match(worksheet2.cells(R,1), worksheet2.range("A:A"),0)
If not application.isnumber(y) Then
worksheet2.cells(x,1).copy destination:=worksheet1.cells(**?????????**)
So, can i return all three column values using one index match formula? If not how can i write the search function in VB? Please help.
This code is executed within the workbook where the search is initiated.
Private Sub CmdBtn_Click()
On Error GoTo workbookErr
Dim WbMaster As Worksheet: Set WbMaster = Workbooks("MasterWorkBook.xlsm").Worksheets("Sheet1")
Dim WbCopyTo As Worksheet: Set WbCopyTo = ThisWorkbook.Worksheets("Sheet1")
Dim rangeWbCopyTo As Range, rangeWbMaster As Range
Dim cellWbCopyTo As Range, cellWbMaster As Range
Dim i As Integer
With WbMaster
Set rangeWbMaster = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
With WbCopyTo
Set rangeWbCopyTo = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
For Each cellWbCopyTo In rangeWbCopyTo
For Each cellWbMaster In rangeWbMaster
If cellWbCopyTo.Value = cellWbMaster.Value Then
For i = 0 To 2
cellWbCopyTo.Offset(0, 1 + i).Value = cellWbMaster.Offset(0, 1 + i).Value
Next i
Exit For
End If
Next cellWbMaster
Next cellWbCopyTo
Exit Sub
workbookErr:
MsgBox "Open MasterWorkBook before executing the search.", vbCritical
End Sub
I am currently working on a spreadsheet and would like to utilize vlookup, but would prefer if it was through VBA.
I attached two screenshots of sheets, so you guys could visually see what i am trying to do.
Essentially I am trying to pull the "Priority" from sheet IW38 column K and place it on sheet "IW47" column R, but by using the order number as the matching info. The order numbers are in Column "E" in sheet IW47 and Column "A" in sheet IW47.
Below is the current macro I attempted to use:
Sub PriorityNUM()
'Variables----------------------------------------
'Defining WorkBook
Dim wb As Workbook
'Defining Sheets----------------------------------------------
'Working Asset Sheet
Dim IW47ws As Worksheet
'Sheet for Parts List Submission
Dim IW38ws As Worksheet
'Setting Worksheets
Set IW47ws = Sheets("IW47")
Set IW38ws = Sheets("IW38")
'Defigning Ranges within Worksheets----------------------------
Dim IW38rng As Range
'Setting Ranges within Submit Worksheets-------------------
Set IW38rng = IW38ws.Range("A:Z")
'Defining the Last Cell in Each Task Column----------------
Dim IW47last As Long
'Assigning Values to Last Row Variables
IW47last = IW47ws.Range("E" & Rows.Count).End(xlUp).Row
'Updating Drawings Identified---------------------------------------------------
Dim PriorityCell As Range
Dim PriorityLookup As String
For Each PriorityCell In IW47ws.Range("R:R")
If IsEmpty(DICell.Offset(0, -13).Value) Then
Exit For
End If
On Error Resume Next
PriorityLookup = WorksheetFunction.VLookup(PriorityCell.Offset(0, -13), IW38rng, 11, False)
If Err = 0 Then
PriorityCell.Value = PriorityLookup
Else
Err.Clear
End If
On Error GoTo 0
Next PriorityCell
End Sub
Any help would be greatly appreciated.
Thanks,
Juan
Readability
OP, your code can be restructured like below. I also used some short hand variables to make things easier. Your variable names would ideally be concise (easy to read and short to type). Readability goes a long way in troubleshooting.
Let me know once you have seen this so I can delete
Sub PNum()
Dim ws47 As Worksheet: Set ws47 = ThisWorkbook.Sheets("IW47")
Dim ws38 As Worksheet: Set ws38 = ThisWorkbook.Sheets("IW38")
Dim Arr As Range: Set Arr = ws38.Range("A:K")
Dim LR As Long, MyCell As Range, Priority As String
LR = ws47.Range("E" & ws47.Rows.Count).End(xlUp).Row
For Each MyCell In ws47.Range("R2:R" & LR)
If IsEmpty(MyCell.Offset(-13)) Then Exit Sub
On Error Resume Next
Priority = WorksheetFunction.VLookup(MyCell.Offset(, -13), Arr, 11, 0)
If Err = 0 Then
MyCell = Priority
Else
Err.Clear
End If
On Error GoTo 0
Next MyCell
End Sub
I'm working with an excel sheet that converts addresses from one format to another, pastes it in a sheet, and is then supposed to paste the correctly formatted addresses into the next available row in a master sheet of addresses that has thousands of records.
There could be hundreds of addresses that need to be pasted to the master sheet, so I'm trying to avoid limiting my rows and ranges by specific references for example a range like ("A2:A6790") would not work because the lists can get long in both the conversion sheet and the master sheet.
In the example below I use just one address but I need the code to be able to copy paste all the rows that have data (but not the header):
I need the highlighted row to copy to here:
I had to black out some of the addresses for privacy reasons, but I highlighted the row count to show how many records there are.
Here's my code:
`
Private Sub Convert()
Dim sap As Worksheet: Set sap = Sheets("SAP")
Dim con As Worksheet: Set con = Sheets("CONVERSION")
Dim abrv As Worksheet: Set abrv = Sheets("ABRV")
Dim slip As Worksheet: Set slip = Sheets("SLIP")
Dim ads As Worksheet: Set ads = Sheets("ADS")
Dim adsrng As Range: Set adsrng = ads.Range("B:B")
Dim conads As Range: Set conads = con.Range("W:W")
Dim saprngQW As Range: Set saprngQW = sap.Range("q:w")
Dim conrngOU As Range: Set conrngOU = con.Range("o:u")
Dim saprngDO As Range: Set saprngBO = sap.Range("B:O")
Dim conrngBN As Range: Set conrngBN = con.Range("B:N")
Dim sapcity2 As Range: Set sapcity2 = sap.Range("o:o")
Dim concity2 As Range: Set concity2 = con.Range("x:x")
Dim sapunion As Range: Set sapunion = Union(saprngQW, saprngBO)
Dim FndList, x&
'Dim nextrow As Long
'nextrow = slip.Cells(Rows.Count, "A").End(xlUp).Row + 1
'Dim pasteslip As Range: Set pasteslip = slip.Range("A" & nextrow)
sap.Select
sapunion.Copy
con.Select
con.Range("a:a").PasteSpecial xlPasteValues
sap.Select
sapcity2.Copy
con.Select
concity2.PasteSpecial xlPasteValues
adsrng.Copy
con.Select
conads.PasteSpecial xlPasteValues
FndList = abrv.Cells(1, 1).CurrentRegion
For x = 1 To UBound(FndList)
con.Cells.Replace What:=FndList(x, 1), Replacement:=FndList(x, 2), LookAt:=xlWhole, MatchCase:=True
Next
con.Select
con.Range("a:x").Copy slip.Range("A:X" & Rows.Count).End(xlUp).Offset(1, 0)
's2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes *this
was a different approach I was going to try if there's no way to
fix things*
'it comes from this code:
'Sub CopyUnique()
'Dim s1 As Worksheet, s2 As Worksheet
'Set s1 = Sheets("Main")
'Set s2 = Sheets("Count")
's1.Range("B:B").Copy s2.Range("a" & nextrow)
's2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
'End Sub
End Sub
`
I commented out some of the code I tried using before (I kept getting paste area is out of range). The error I'm getting now is: Run-time error '1004': Method 'Range' of object'_Worksheet' failed, when it gets to this line con.Range("a:x").Copy slip.Range("A:X" & Rows.Count).End(xlUp).Offset(1, 0)
Any ideas what I can do? I feel like I'm so close but there's something obvious staring me in the face that I can't see.
Figured it out! Adapted some code I used for another project. Wasn't able to get
it to skip copies but it works!
Dim ldestlRow As Long, i As Long
Dim ins As Variant
Dim h As String, won As String
Dim wo As Range
ldestlRow = slip.Cells(Rows.Count, 1).End(xlUp).Row + 1
ins = con.UsedRange
For i = 2 To UBound(ins)
won = ins(i, 7)
Set wo = Range("W2:W" & ldestlRow).Find(what:=won)
If wo Is Nothing Then
ldestlRow = slip.Cells(Rows.Count, 1).End(xlUp).Row + 1
con.Range("A" & i).EntireRow.Copy slip.Range("A" & ldestlRow)
End If
I'm pretty new at this and I've gone through a ton of bundle of tutorials but I can't seem to grasp the concept of how to achieve this result in excel VBA. I'll try being as detailed as possible.
I have a folder with 3 x Excel files -
Script.xlsx (Just a button that holds the script/macro)
WhiteCrown.xlsx (the workbook I'd like to copy the data from)
PackCon.xlsx (the workbook I'd like the data pasted into)
Concept:
If Workbook ("WhiteCrown.xlsx") contains value in Column B5:B10000 which = Workbook ("PackCon.xlsx") Column B5:B10000 AND Workbook ("WhiteCrown.xlsx") contains a value in Column E
There are 2 cells I don't want the value of E copied - "soy-milk" "Pepsi-max"
The check is to be looped till column b
Reaches 10000
:) thanks in advance
Sub ConvertData()
Dim i As Integer, n As Integer
Dim Desc As Range, ExDesc As Range
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngLookup As Range
Dim v
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\WhiteCrown.xlsx")
Set ws1 = wb1.Sheets("BOMQ")
Set wb2 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\PackCon.xlsx")
With wb2.Sheets("("BOMQ")")
Set rngLookup = .Range(.Cells(7, 2), _
.Cells(7, 2).End(xlDown)).Resize(, 3)
End With
With ws1
i = 7
Do Until .Cells(i, 2) = ""
v = Application.VLookup(.Cells(i, 2).Value, rngLookup, 3, False)
If Not IsError(v) Then .Cells(i, 4).Value = v
i = i + 1
Loop
End With
wb2.Close False
End Sub
*Script updated but still not working
I do not Understand what data you would like to copy. I have exhibited the logic to do so. Tested and working.
Option Explicit
Private Sub btnScript_Click()
Dim WhiteCrown As Workbook, PackCon As Workbook, DestWorkbook As Workbook
Dim SheetWhiteCrown As Worksheet, SheetPack As Worksheet
Dim RowIndex As Long
Dim RngWhite As Range
Dim RngWhiteCount As Long
Dim ValBWhite, ValBPack, ValEWhite As String
Application.ScreenUpdating = False
Set WhiteCrown = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\WhiteCrown.xlsx")
Set SheetWhiteCrown = WhiteCrown.Sheets("BOMQ")
Set RngWhite = SheetWhiteCrown.Range("RngWhiteData")
RngWhiteCount = SheetWhiteCrown.Range("RngWhiteData").Rows.Count + 5
Set PackCon = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\PackCon.xlsx")
Set SheetPack = PackCon.Sheets("BOMQ")
Set DestWorkbook = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\Script.xlsx")
For RowIndex = 5 To RngWhiteCount
ValBWhite = SheetWhiteCrown.Cells(RowIndex, "B").Value
ValBPack = SheetPack.Cells(RowIndex, "B").Value
ValEWhite = SheetWhiteCrown.Cells(RowIndex, "E").Value
If Not ValBWhite = "" And ValBWhite = "" Then
If Not ((ValEWhite = "SoyMilk") Or (ValEWhite = "Pepsi")) Then
'Perform your copy to Destworkbook or vlookup or anything
Else
'Do Nothing
End If
End If
Next RowIndex
WhiteCrown.Close
PackCon.Close
DestWorkbook.Close False
End Sub
Never use hardocode ranges like Range("B10:E60"). Best coding practise involved using named ranges as in the above code(example "RngWhiteData" is named range). Add error validations.
If you're satisfied please vote this answer.
Regards,
Mani