I have the below line that is receiving a "Object doesn't support the property or method error, but i am not seeing any issues.
Dim compliance As Worksheet
Dim report As Worksheet
Dim completeList As Worksheet
Sub getcompliance()
Dim i As Long
Dim n As Long
Dim Source As String
Set compliance = ActiveWorkbook.Worksheets("Compliance")
Set report = ActiveWorkbook.Worksheets("Report")
For i = 3 To report.UsedRange.Rows.Count
For n = 2 To compliance.UsedRange.Rows.Count
report(i, 19) = Application.WorksheetFunction.VLookup(report("i, 3"), compliance("A1:AC2400"), 29, False)
Next n
Next i
End Sub
Your line saying
report(i, 19) = Application.WorksheetFunction.VLookup(report("i, 3"), compliance("A1:AC2400"), 29, False)
should probably say
report.Cells(i, 19) = Application.WorksheetFunction.VLookup(report.Cells(i, 3), compliance.Range("A1:AC2400"), 29, False)
but, if so, why are you doing that in a For n loop?
Perhaps you mean your code to be:
Dim compliance As Worksheet
Dim report As Worksheet
Dim completeList As Worksheet
Sub getcompliance()
Dim i As Long
Set compliance = ActiveWorkbook.Worksheets("Compliance")
Set report = ActiveWorkbook.Worksheets("Report")
For i = 3 To report.UsedRange.Rows.Count
report.Cells(i, 19) = Application.WorksheetFunction.VLookup(report.Cells(i, 3), compliance.Range("A1:AC" & compliance.UsedRange.Rows.Count), 29, False)
'Or, simply using the full columns:
'report.Cells(i, 19) = Application.WorksheetFunction.VLookup(report.Cells(i, 3), compliance.Range("A:AC"), 29, False)
Next i
End Sub
' vvvvv vvvvvvvvvvvvv
report.Cells(i, 19) = WorksheetFunction.VLookup(report.Cells(i, 3), compliance.Range("A1:AC2400"), 29, False)
' ^^^^^^
Related
I receive the error: Method or data member not found at line
.SendKeys ("")
I am scraping from a screen and this the command I send to place the cursor in the right place before sending the command in the next line to change screens. I do not understand why I am receiving this error.
Sub RLinfo()
Dim sys
Dim sess
Dim chan
Dim ws As Worksheet
Dim x As Integer
Dim y As Integer
Dim linecount As Long
' RL Information xxxx
Set Host = CreateObject("BZWh.WhllObj")
Host.OpenSession 0, 1, "xxxx.zmd", 30, 1
Set sess = Host.ActiveSession
Set chan = sess.Screen
Set ws = Worksheets("Information")
With ws
x = 14
y = 19
Set OUTPUTSHEET = ActiveWorkbook.Sheets("Information")
With chan
linecount = 2
Do While OUTPUTSHEET.Cells(linecount, 30) = "Zip"
RL = Format(OUTPUTSHEET.Cells(linecount, 1), "000000000")
.SendKeys ("<Home>")
.SendKeys ("/for x203<Enter>")
.waithostquiet (10)
.SendKeys (RL & "<Enter>")
.waithostquiet (10)
If Trim(.getstring(14, 2, 30)) = "RL WAS NOT FOUND" Then
OUTPUTSHEET.Cells(linecount, 20) = "RL No Longer In X203"
GoTo Found
Else
End If
OUTPUTSHEET.Cells(linecount, 17) = Trim(.getstring(11, 6, 6))
OUTPUTSHEET.Cells(linecount, 18) = Trim(.getstring(8, 27, 12))
OUTPUTSHEET.Cells(linecount, 19) = Trim(.getstring(9, 27, 12))
OUTPUTSHEET.Cells(linecount, 20) = Trim(.getstring(5, 41, 26))
For x = 14 To 20
If Trim(.getstring(x, 2, 7)) = "NUM" Then
OUTPUTSHEET.Cells(linecount, 21) = Trim(.getstring(x, 11, 11))
GoTo Found
Else
End If
Next x
If Trim(.getstring(23, 72, 6)) = "N MORE" Then
.SendKeys ("<PA1>")
.waithostquiet (10)
For y = 19 To 22
If Trim(.getstring(y, 2, 7)) = "NUM" Then
OUTPUTSHEET.Cells(linecount, 21) = Trim(.getstring(y, 11, 11))
GoTo Found
Else
End If
Next y
Else
End If
Found:
linecount = linecount + 1
Loop
End With
End With
ws.Cells(2, 31) = linecount
endM:
End Sub
The cause of my problem was that I was not disconnecting from the Host when I moved between modules. At the start of each module I was reconnecting to the Host even though I had not disconnected in the previous module and this caused the run time error.
I've included the base code that currently runs to essentially pull out info for a specific product category based on a larger master listing (approx. 4000 lines by 36 columns). Previously this was not an issue, as the only codes listed and pulled out to individual sheets, were all is use; over time though, some of the older assigned product numbers are being discontinued and no longer in use. All I'm trying to do is modify the existing structure so that it first does a sweep through the master listing to verify whether or not any lines match the c.Value and d.Value - if there are no lines that meet the matching c.Value and d.Value criteria then it should just perform the action in the If statement inside the loop (ie. delete the old sheet, make a new one, and populate "G2" with a generic "item code not located" value); if any lines are found that meet the c and d.value criteria then it goes through the normal process.
Option Explicit
Sub Item()
CreateDeptReport "Item"
End Sub
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
On Error GoTo Err_Execute
Application.ScreenUpdating = False
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
LCopyToRow = 11
Do
If c.Value = 2516 And d.Value = "37A" And Not e.Value = "T1" And Not e.Value = "T3" Then
If shtRpt Is Nothing Then
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Item").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = "Item"
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until IsEmpty(c.Offset(0, -1))
ThisWorkbook.Worksheets("Item").Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
It seems to me that you always want a new Worksheet for the Item.
So create the new worksheet first, then run the routine to find and fill the new worksheet with the records from the Master worksheet and use a variable (Dim blItmFound As Boolean) to flag when any record is found and at the end if there where no records found then enter in the new worksheet at G2 the generic string you want (see Rem Validate Records).
Please note that I changed "Item" for the value of the Variable Item and also changed this line:
Loop Until IsEmpty(c.Offset(0, -1))
for this:
Loop Until c.Value = Empty
for more details see IsEmpty Function
This is your code adjusted:
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
Dim blItmFound As Boolean
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Application.ScreenUpdating = False
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
Rem Delete Item Worksheet
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets(Item).Delete
Application.DisplayAlerts = True
On Error GoTo Err_Execute
Rem Add New Item Worksheet
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = Item
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
Rem Get Records from Master
LCopyToRow = 11
blItmFound = False
Do
If c.Value = 2516 _
And d.Value = "37A" _
And Not e.Value = "T1" _
And Not e.Value = "T3" Then
blItmFound = True
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until c.Value = Empty
Rem Validate Records
Select Case blItmFound
Case True
ThisWorkbook.Worksheets(Item).Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Case False
ThisWorkbook.Worksheets(Item).Range("G2").Value = "Item: [" & Item & "] code not located"
End Select
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Based on what I've read, it sounds like you should just search for the values in their respective columns beforehand. This is also assuming that if one of those conditions is false, you'll enter your new code. So you could do something like:
Set cRange = shtMaster.Columns("AI:AI")
Set dRange = shtMaster.Columns("H:H")
If cRange.Find(2516) Is Nothing Or dRange.Find("37A") Is Nothing Then
'do code when either one of these conditions is false
Else
'both values are found in their respective columns
'do existing code
EDIT:
Set rng = Range("AI:AI")
Set origCell = rng.Find(2516)
Set currCell = origCell
Do
Set currCell = rng.FindNext(currCell)
If shtMaster.Range("H" & currCell.Row).Value = "37A" Then
boolMatchingPair = True
Exit Do
End If
Loop While currCell.Row <> origCell.Row
If boolMatchingPair = True
'found match
Else
'no match
I'm working on this code and keep getting errors. It will all compile, but I keep getting run-time errors. I'm trying to compare two different sheets and then highlight cells that do not match. I am not sure where the error(s) are occurring. Any help would be greatly appreciated.
Sub David()
Dim Initial_PO As Double
Dim Initial_Firmed As Range
Dim Initial_Agreed_Ship As Range
Dim Initial_Actual_Ship As Range
Dim Initial_Agreed_Delivery As Range
Dim Initial_Actual_Delivery As Range
Dim Initial_Requested_Quantity As Range
Dim Initial_Actual_Quantity As Range
Dim Initial_QMetric As Double
Dim Initial_DMetric As Double
Dim Final_PO As Double
Dim Final_Firmed As Range
Dim Final_Agreed_Ship As Range
Dim Final_Actual_Ship As Range
Dim Final_Agreed_Delivery As Range
Dim Final_Actual_Delivery As Range
Dim Final_Requested_Quantity As Range
Dim Final_Actual_Quantity As Range
Dim Final_QMetric As Double
Dim Final_DMetric As Double
Dim Initial_Agreed_Delivery_Date As Date
Dim Final_Agreed_Delivery_Date As Date
Dim Initial_Actual_Delivery_Date As Date
Dim Final_Actual_Delivery_Date As Date
Dim Today As Date
'Dim NumRow As Integer
Dim i As Long
Dim BulkLT As Double
For i = 2 To 3000
Sheets("Initial").Select
Set Initial_PO = Cells(i, 7)
Set Initial_Firmed = Cells(i, 9)
Set Initial_Agreed_Ship = Cells(i, 10)
Set Initial_Actual_Ship = Cells(i, 11)
Set Initial_Agreed_Delivery = Cells(i, 13)
Set Initial_Actual_Delivery = Cells(i, 14)
Set Initial_Requested_Quantity = Cells(i, 15)
Set Initial_Actual_Quantity = Cells(i, 16)
Sheets("Final").Select
Set Final_PO = Cells(i, 7)
Set Final_Firmed = Cells(i, 9)
Set Final_Agreed_Ship = Cells(i, 10)
Set Final_Actual_Ship = Cells(i, 11)
Set Final_Agreed_Delivery = Cells(i, 13)
Set Final_Actual_Delivery = Cells(i, 14)
Set Final_Requested_Quantity = Cells(i, 15)
Set Final_Actual_Quantity = Cells(i, 15)
'Initial Highlighting
If (Initial_PO = Final_PO) Then
If Not (Initial_Firmed = Final_Firmed) Then
Initial_Firmed.Interior.Color = RGB(225, 225, 0) And Final_Firmed.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Agreed_Ship = Final_Agreed_Ship) Then
Initial_Agreed_Ship.Interior.Color = RGB(225, 225, 0) And Final_Agreed_Ship.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Actual_Ship = Final_Actual_Ship) Then
Initial_Actual_Ship.Interior.Color = RGB(225, 225, 0) And Final_Actual_Ship.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Agreed_Delivery = Final_Agreed_Delivery) Then
Initial_Agreed_Delivery.Interior.Color = RGB(225, 225, 0) And Final_Agreed_Delivery.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Actual_Delivery = Final_Actual_Delivery) Then
Initial_Actual_Delivery.Interior.Color = RGB(225, 225, 0) And Final_Actual_Delivery.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Requested_Quantity = Final_Requested_Quantity) Then
Initial_Requested_Quantity.Interior.Color = RGB(225, 225, 0) And Final_Requested_Quantity.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Actual_Quantity = Final_Actual_Quantity) Then
Initial_Actual_Quantity.Interior.Color = RGB(225, 225, 0) And Final_Actual_Quantity.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Requested_Quantity = Initial_Actual_Quantity) Then
Initial_Requested_Quantity.Interior.Color = RGB(225, 225, 0) And Initial_Actual_Quantity.Interior.Color = RGB(225, 225, 0)
End If
If Not (Final_Requested_Quantity = Final_Actual_Quantity) Then
Final_Requested_Quantity.Interior.Color = RGB(225, 225, 0) And Final_Actual_Quantity.Interior.Color = RGB(225, 225, 0)
End If
'Metric Calculation
Initial_QMetric = ((Initial_Actual_Quantity / Initial_Requested_Quantity) * 100)
Final_QMetric = ((Final_Actual_Quantity / Final_Requested_Quantity) * 100)
Sheets("Initial").Select
Cells(i, 27) = Initial_QMetric
Sheets("Final").Select
Cells(i, 27) = Final_QMetric
If (Initial_QMetric < 90 Or Initial_QMetric > 110) Then
Sheets("Initial").Select
Cells(i, 27).Interior.Color = RGB(225, 225, 0)
End If
If (Final_QMetric < 90 Or Final_QMetric > 110) Then
Sheets("Final").Select
Cells(i, 27).Interior.Color = RGB(225, 225, 0)
End If
Initial_DMetric = DateDiff("d", Initial_Agreed_Delivery_Date, Initial_Actual_Delivery_Date)
Final_DMetric = DateDiff("d", Final_Agreed_Delivery_Date, Final_Actual_Delivery_Date)
Sheets("Initial").Select
Cells(i, 28) = Initial_DMetric
Sheets("Final").Select
Cells(i, 28) = Final_DMetric
If (Initial_DMetric > 5 Or Initial_DMetric < (-5)) Then
Sheets("Initial").Select
Cells(i, 28).Interior.Color = RGB(225, 225, 0)
End If
If (Final_DMetric > 5 Or Final_DMetric < (-5)) Then
Sheets("Final").Select
Cells(i, 28).Interior.Color = RGB(225, 225, 0)
End If
'Bulk Lead time
BulkLT = DateDiff("d", Today, Final_Agreed_Ship)
If IsEmpty(Final_Firmed) = True Then
If (BulkLT < 90) Then
Final_Firmed.Interior.Color = RGB(225, 225, 0)
End If
End If
Else: MsgBox ("PO Numbers in row" & i & "do not match")
End If
Next i
End
End Sub
as for the last error, you're dimming Initial_PO as a value type (Dim Initial_PO As Double) and then trying to set it as an object (Set Initial_PO = Cells(i, 7)): you choose a type (value or object) and then act consistently
furthermore you could get much more control over your code and reduce its execution time by referencing ranges and avoiding Select() method and Selection property for them
finally you're duplicating a lot of code, and this also can lead to unwanted typos and loose code control
for all what above you may want to consider this code:
Option Explicit
Sub David()
Dim initialSht As Worksheet: Set initialSht = Worksheets("Initial")
Dim finalSht As Worksheet: Set finalSht = Worksheets("Final")
Dim i As Long, lastRow As Long
lastRow = initialSht.Cells(initialSht.Rows.Count, 7).End(xlUp).Row 'get the "Initial" last non blank row index in column 7
For i = 2 To lastRow
If initialSht.Cells(i, 7) = initialSht.Cells(i, 7) Then
DoChecksAndFormat initialSht, finalSht, i
Else
MsgBox ("PO Numbers in row '" & i & "' do not match")
End If
Next i
End Sub
Sub DoChecksAndFormat(initialSht As Worksheet, finalSht As Worksheet, i As Long)
Dim Initial_Firmed As Range
Dim Initial_Agreed_Ship As Range
Dim Initial_Actual_Ship As Range
Dim Initial_Agreed_Delivery As Range
Dim Initial_Actual_Delivery As Range
Dim Initial_Requested_Quantity As Range
Dim Initial_Actual_Quantity As Range
Dim Initial_QMetric As Double
Dim Final_Firmed As Range
Dim Final_Agreed_Ship As Range
Dim Final_Actual_Ship As Range
Dim Final_Agreed_Delivery As Range
Dim Final_Actual_Delivery As Range
Dim Final_Requested_Quantity As Range
Dim Final_Actual_Quantity As Range
Dim Initial_Agreed_Delivery_Date As Date
Dim Final_Agreed_Delivery_Date As Date
Dim Initial_Actual_Delivery_Date As Date
Dim Final_Actual_Delivery_Date As Date
Dim BulkLT As Double
'initialize your relevant variables
Init initialSht, i, Initial_Firmed, Initial_Agreed_Ship, Initial_Actual_Ship, Initial_Agreed_Delivery, Initial_Actual_Delivery, Initial_Requested_Quantity, Initial_Actual_Quantity
Init finalSht, i, Final_Firmed, Final_Agreed_Ship, Final_Actual_Ship, Final_Agreed_Delivery, Final_Actual_Delivery, Final_Requested_Quantity, Final_Actual_Quantity
'Initial Highlighting
CheckAndColor Initial_Firmed, Final_Firmed
CheckAndColor Initial_Agreed_Ship, Final_Agreed_Ship
CheckAndColor Initial_Actual_Ship, Final_Actual_Ship
CheckAndColor Initial_Agreed_Delivery, Final_Agreed_Delivery
CheckAndColor Initial_Actual_Delivery, Final_Actual_Delivery
CheckAndColor Initial_Requested_Quantity, Final_Requested_Quantity
CheckAndColor Initial_Actual_Quantity, Final_Actual_Quantity
CheckAndColor Initial_Requested_Quantity, Initial_Actual_Quantity
CheckAndColor Final_Requested_Quantity, Final_Actual_Quantity
'Metric Calculation
QMetric initialSht.Cells(i, 27), Initial_Actual_Quantity.Value, Initial_Requested_Quantity.Value
QMetric finalSht.Cells(i, 27), Final_Actual_Quantity.Value, Final_Requested_Quantity.Value
DMetric initialSht.Cells(i, 28), Initial_Agreed_Delivery_Date, Initial_Actual_Delivery_Date
DMetric finalSht.Cells(i, 28), Final_Agreed_Delivery_Date, Final_Actual_Delivery_Date
'Bulk Lead time
BulkLT = DateDiff("d", Now, Final_Agreed_Ship)
If IsEmpty(Final_Firmed) Then
If BulkLT < 90 Then Final_Firmed.Interior.Color = RGB(225, 225, 0)
End If
End Sub
Sub Init(sht As Worksheet, i As Long, Firmed As Range, Agreed_Ship As Range, Actual_Ship As Range, Agreed_Delivery As Range, Actual_Delivery As Range, Requested_Quantity As Range, Actual_Quantity As Range)
With sht
Set Firmed = .Cells(i, 9)
Set Agreed_Ship = .Cells(i, 10)
Set Actual_Ship = .Cells(i, 11)
Set Agreed_Delivery = .Cells(i, 13)
Set Actual_Delivery = .Cells(i, 14)
Set Requested_Quantity = .Cells(i, 15)
Set Actual_Quantity = .Cells(i, 16)
End With
End Sub
Sub CheckAndColor(rng1 As Range, rng2 As Range)
If Not (rng1 = rng2) Then rng1.Interior.Color = RGB(225, 225, 0) And rng2.Interior.Color = RGB(225, 225, 0)
End Sub
Sub QMetric(rng As Range, Actual_Quantity As Double, Requested_Quantity As Double)
Dim QMetric As Double
QMetric = (Actual_Quantity / Requested_Quantity) * 100
rng.Value = QMetric
If (QMetric < 90 Or QMetric > 110) Then rng.Interior.Color = RGB(225, 225, 0)
End Sub
Sub DMetric(rng As Range, Agreed_Delivery_Date As Date, Actual_Delivery_Date As Date)
Dim DMetric As Double
DMetric = DateDiff("d", Agreed_Delivery_Date, Actual_Delivery_Date)
rng.Value = DMetric
If (DMetric > 5 Or DMetric < -5) Then rng.Interior.Color = RGB(225, 225, 0)
End Sub
where I also made some little adjustments:
for example in your code you wrote:
Set Initial_Actual_Quantity = Cells(i, 16)
...
Set Final_Actual_Quantity = Cells(i, 15)
and I assumed that column 16 would do for both sheets
I have a workbook doing a Vlookup in another workbook and I have it opening the file and then running a Vlookup. For some reason if it opens the file first, it only returns #N/A, but if the file is already open, it finds the values just fine. Is it something in the code?
Private Sub BarcodeVlookup(beginningNum As Integer, endingNum As Integer)
Dim pvsReport As Excel.Workbook
Dim tracker As Excel.Workbook
Dim lookFor As Range
Dim brandRng As Range
Dim i As Integer
Dim k As Integer
Dim r As Integer
Dim j As String
If Not IsFileOpen("\\msfs05\Data1\SHARE\MDCM_Reports\LowesCom\PVS\PVS_Report.xlsx") Then
Workbooks.Open ("\\msfs05\Data1\SHARE\MDCM_Reports\LowesCom\PVS\PVS_Report.xlsx")
'Cut Barcode Column and Insert it at beginning of sheet
Columns("J").Cut
Columns("A").Insert Shift:=xlToRight
Set pvsReport = Workbooks("PVS_Report.xlsx")
Set tracker = ThisWorkbook
Else
Set pvsReport = Workbooks("PVS_Report.xlsx")
Set tracker = ThisWorkbook
End If
k = beginningNum
Do Until k = endingNum + 1
tracker.Sheets(1).Cells(k, "D").Value = Application.VLookup(Cells(k, "B"), pvsReport.Sheets(1).Range("A:M"), 13, False)
tracker.Sheets(1).Cells(k, "A").Value = Application.VLookup(Cells(k, "B"), pvsReport.Sheets(1).Range("A:H"), 8, False)
tracker.Sheets(1).Cells(k, "C").Value = Application.VLookup(Cells(k, "B"), pvsReport.Sheets(1).Range("A:B"), 2, False)
If IsEmpty(Cells(k, "C").Value) Then
tracker.Sheets(1).Cells(k, "C").Value = Application.VLookup(Cells(k, "B"), pvsReport.Sheets(1).Range("A:C"), 3, False)
End If
tracker.Sheets(1).Cells(k, "E").Value = Application.VLookup(Cells(k, "B"), pvsReport.Sheets(1).Range("A:R"), 18, False)
tracker.Sheets(1).Cells(k, "F").Value = Application.VLookup(Cells(k, "B"), pvsReport.Sheets(1).Range("A:P"), 16, False)
k = k + 1
Loop
MsgBox "Done! c[_] "
Unload Me
End Sub
Maybe you should check if the first argument of Application.VLookup is referencing the correct sheet, since you didn't use either tracker or pvsReport before Cells(k, "B").
The active sheet probably changes when you open the workbook, so Cells(k, "B") will get data from pvsReport instead of tracker.
If pvsreport is already open, then the active sheet won't change.
Try changing:
Application.VLookup(Cells(k, "B"), ...
to:
Application.VLookup(tracker.Sheets(1).Cells(k, "B"), ...
I changed tracker to point to ThisworkBook.WorkSheets(1). Application.Vlookup may work but you should use WorkSheetFunction.Vlookup. I fully qualified your reference to Cells(k, "B"). You are inseting column J to the left of Column A. Is that on ThisWorkbook.Worksheets(1) You should fully qualify that reference also. Using a With statement when dealing with such long references makes debugging easier.
Private Sub BarcodeVlookup(beginningNum As Integer, endingNum As Integer)
Dim pvsReport As Excel.Workbook
Dim tracker As Excel.Worksheet
Dim lookFor As Range
Dim brandRng As Range
Dim i As Integer
Dim k As Integer
Dim r As Integer
Dim j As String
Set tracker = ThisWorkbook.Worksheets(1)
If Not IsFileOpen("\\msfs05\Data1\SHARE\MDCM_Reports\LowesCom\PVS\PVS_Report.xlsx") Then
Workbooks.Open ("\\msfs05\Data1\SHARE\MDCM_Reports\LowesCom\PVS\PVS_Report.xlsx")
'Cut Barcode Column and Insert it at beginning of sheet
Columns("J").Cut
Columns("A").Insert Shift:=xlToRight
End If
Set pvsReport = Workbooks("PVS_Report.xlsx")
k = beginningNum
With pvsReport.Worksheets(1)
Do Until k = endingNum + 1
tracker.Cells(k, "D").Value = WorksheetFunction.VLookup(tracker.Cells(k, "B"), .Range("A:M"), 13, False)
tracker.Cells(k, "A").Value = WorksheetFunction.VLookup(tracker.Cells(k, "B"), .Range("A:H"), 8, False)
tracker.Cells(k, "C").Value = WorksheetFunction.VLookup(tracker.Cells(k, "B"), .Range("A:B"), 2, False)
If IsEmpty(Cells(k, "C").Value) Then
tracker.Cells(k, "C").Value = WorksheetFunction.VLookup(tracker.Cells(k, "B"), .Range("A:C"), 3, False)
End If
tracker.Cells(k, "E").Value = WorksheetFunction.VLookup(tracker.Cells(k, "B"), .Range("A:R"), 18, False)
tracker.Cells(k, "F").Value = WorksheetFunction.VLookup(tracker.Cells(k, "B"), .Range("A:P"), 16, False)
k = k + 1
Loop
End With
MsgBox "Done! c[_] "
Unload Me
End Sub
I am having an issue referencing ranges in my vba program. The following snippet of code shows my original code:
With Worksheets("Overall 6 mo")
.Columns("A:G").ColumnWidth = 13.57
.Range("A1:Z100").Rows.RowHeight = 15
.Columns("F:G").NumberFormat = "0.00%"
.Range("B3:G3") = Worksheets("TEMPLATE").Range("A3:F3").Value
.Range("F4:G100") = Worksheets("TEMPLATE").Range("E4:F100").Formula
.Range("A1").NumberFormat = "#"
.Range("A1") = .Name
End With
This would throw the "runtime 1004 application-defined or object-defined error" after going through line 3.
So then, I changed
.Range("A1:Z100").Rows.RowHeight = 15
to
.Rows.RowHeight = 15
The point was to make the cells that i need to use have a height of 15 so the change didn't hurt my program. And now, it will allow that but then throw the same error at the next line, where I reference a range again. So I'm trying to figure out why it won't allow me to use .range ? Or at least how I can fix it?
UPDATE:
I have come to realize that I cannot use the .Range method anywhere in my workbook (not just in the instance above). What would disable me to use .Range everywhere?
UPDATE2:
It will now no longer let me use the .Columns method in the second line. I haven't done anything but step through it a couple times. What is wrong with this thing?
UPDATE3:
It seems that when i restart excel, it will allow me to run the worksheet "Overall 6 mo" code once, and then starts throwing the error every time after that. I've included the code for the rest of the sheet.
Option Explicit
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Dim shIndex As Integer
Dim rowIndex As Integer
Dim myLastRow As Integer
Dim shLastRow As Integer
Dim col As Integer
myLastRow = Worksheets("Overall 6 mo").Cells(65536, 1).End(xlUp).Row
' Format Worksheet
Sheets("Overall 6 mo").Cells.Clear
With Worksheets("Overall 6 mo")
.Columns.ColumnWidth = 13.57
.Rows.RowHeight = 15
.Columns("F:G").NumberFormat = "0.00%"
.Range("B3:G3") = Worksheets("TEMPLATE").Range("A3:F3").Value
.Range("F4:G100") = Worksheets("TEMPLATE").Range("E4:F100").Formula
.Range("A1").NumberFormat = "#"
.Range("A1") = .Name
End With
' Clear current sheet data
myLastRow = Worksheets("Overall 6 mo").Cells(65536, 2).End(xlUp).Row
Worksheets("Overall 6 mo").Range(Cells(4, 1), Cells(myLastRow, 7)).Clear
' Compile data from last six months and add to and display on "Overall 6 mo" sheet
For shIndex = Worksheets.Count - 5 To Worksheets.Count
Worksheets(shIndex).Activate
myLastRow = Worksheets("Overall 6 mo").Cells(65536, 2).End(xlUp).Row
shLastRow = Worksheets(shIndex).Cells(65536, 1).End(xlUp).Row
Worksheets("Overall 6 mo").Cells(myLastRow + 1, 1).Value _
= MonthName(Month(CDate(Worksheets(shIndex).Name)), False)
Worksheets(shIndex).Range("A4:D" & shLastRow) _
.Copy (Worksheets("Overall 6 mo").Cells(myLastRow + 1, 2))
Next shIndex
' Call UpdateChart to clear and re-add Quality and Cost charts to wks
Call UpdateCharts(Worksheets("Overall 6 mo").Index)
Worksheets("Overall 6 mo").Activate
Application.ScreenUpdating = True
End Sub
You can do row height changes with:
.Range("A1:Z100").RowHeight = 15
And can you use Range Copy method
Worksheets("TEMPLATE").Range("A3:F3").Copy .Range("B3")
Worksheets("TEMPLATE").Range("E4:F100").Copy .Range("F4")
UPDATE:
Option Explicit
Private Sub Worksheet_Activate()
Dim oSh As Worksheet
Dim shIndex As Long
Dim rowIndex As Long
Dim myLastRow As Long
Dim shLastRow As Long
Application.ScreenUpdating = False
Set oSh = ThisWorkbook.Worksheets("Overall 6 mo")
' Format Worksheet
With oSh
.Cells.Clear
.Columns.ColumnWidth = 13.57
.Rows.RowHeight = 15
.Columns("F:G").NumberFormat = "0.00%"
.Range("A1").NumberFormat = "#"
.Range("A1") = .Name
.Range("B3:G3") = Worksheets("TEMPLATE").Range("A3:F3").Value
.Range("F4:G100") = Worksheets("TEMPLATE").Range("E4:F100").Formula
End With
' Clear current sheet data
oSh.Range(oSh.Cells(4, 1), oSh.Cells(GetLastRow(oSh, 2), 7)).Clear
' Compile data from last six months and add to and display on "Overall 6 mo" sheet
For shIndex = Worksheets.Count - 5 To Worksheets.Count
'Worksheets(shIndex).Activate
myLastRow = GetLastRow(oSh, 2)
shLastRow = GetLastRow(Worksheets(shIndex), 1)
oSh.Cells(myLastRow + 1, 1).Value = MonthName(Month(CDate(Worksheets(shIndex).Name)), False)
Worksheets(shIndex).Range("A4:D" & shLastRow).Copy oSh.Cells(myLastRow + 1, 2)
Next shIndex
' Call UpdateChart to clear and re-add Quality and Cost charts to wks
Call UpdateCharts(oSh.Index)
oSh.Activate
Set oSh = Nothing
Application.ScreenUpdating = True
End Sub
Private Function GetLastRow(oSheet As Worksheet, lngColumn As Long) As Long
GetLastRow = oSheet.Cells(oSheet.UsedRange.SpecialCells(xlLastCell).Row + 1, lngColumn).End(xlUp).Row
End Function
Is "TEMPLATE" in the same workbook with Index 1 (or less than Worksheets.Count - 5)? I have comment out Worksheets(shIndex).Activate as seems no need to run this sub every time in the For loop.
RowHeight applies to whole rows, not parts of rows.
So use
.Range("A1:A100").EntireRow.RowHeight = 15
or
.Range("1:100").RowHeight = 15