I wrote some code which works perfectly as it should when I debug it. But when I remove the breakpoint and just run the code, it give a runtime error:
runtime error '1004'
Method Range of object_worksheet failed.
It refers to the next line:
Set copyrange = sh.Range("A" & i & ":E" & i & ",I" & i & ":O" & i & ",Q" & i & ",V" & i) 'name column in sheet = Q
But while debugging it, there isn't a problem. Maybe the cache is full?
Private Sub btnGetDevices_Click()
'open every sheet after summary
'copy columns A,B,C,D,E,I,J,K,L,M,N,O, Q,V to summary
Dim sh As Worksheet
Dim copyrange As Range
Application.ScreenUpdating = False
Sheets("Summary").Rows(4 & ":" & Sheets("Summary").Rows.Count).Delete
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Database" And sh.Name <> "Template" And sh.Name <> "Help" And sh.Name <> "OVERVIEW" And sh.Name <> "Develop" And sh.Name <> "Schedule" And sh.Name <> "Information" And sh.Name <> "Announcements" And sh.Name <> "Summary" Then
sh.Select
LastRow = ActiveSheet.Range("L1048555").End(xlUp).Row
For i = 14 To LastRow
If sh.Range("Q" & i).Value <> Empty And sh.Range("N" & i).Value <> "Designer" And sh.Range("O" & i).Value <> "Layouter" Then
Set copyrange = sh.Range("A" & i & ":E" & i & ",I" & i & ":O" & i & ",Q" & i & ",V" & i) 'name column in sheet = Q
NameDevice = sh.Range("Q" & i).Value
adressDevice = sh.Range("Q" & i)
copyrange.Copy
Sheets("Summary").Select
LastRowsummary = ActiveSheet.Range("A1048555").End(xlUp).Row
Range("B" & LastRowsummary + 1).Select
ActiveSheet.Paste
Range("A" & LastRowsummary + 1) = sh.Name
Range("A" & LastRowsummary + 1, "O" & LastRowsummary + 1).Borders.LineStyle = xlContinuous
Sheets("Summary").Hyperlinks.Add anchor:=Sheets("Summary").Range("N" & LastRowsummary + 1), Address:="", SubAddress:="'" & sh.Name & "'!A1", TextToDisplay:=NameDevice
End If
Next
End If
Next
Application.ScreenUpdating = True
Sheets("Summary").Activate
End Sub
*edit: After some testing I noticed that the error is gone when I use a full range of columns instead of only some columns.
with error:
Set copyrange = sh.Range("A" & i & ",V" & i)
w/o error:
Set copyrange = sh.Range("A" & i & ":E" & i)
*second edit:
I'm using the code from 'Tim Williams'. There was the same error. Instead of using:
rw.Range("A1:E1,I1:O1,Q1,V1").Copy rng.Offset(0, 1)
I've found a workaround. I split it up.
rw.Range("I1:O1").Copy rng.Offset(0, 6)
rw.Range("Q1").Copy rng.Offset(0, 13)
rw.Range("V1").Copy rng.Offset(0, 14)
Now this works without error. But if anyone knows what causes the problem, you may always share it. Thanks in advance.
*third edit:
I still don't know why it doesn't work. It has something to do with range from different columns. The funny (and very frustrated part) is that I use range this way in another sheet and there I don't have this problem. It is driving me mad. Does someone have an idea?
Compiled but not tested"
Private Sub btnGetDevices_Click()
'open every sheet after summary
'copy columns A,B,C,D,E,I,J,K,L,M,N,O, Q,V to summary
Dim sh As Worksheet, shtsumm As Worksheet
Dim copyrange As Range, arrExclude, rw As Range
Dim lastRow As Long, i As Long, rng As Range
Dim NameDevice, adressDevice
'sheets to ignore
arrExclude = Array("Database", "Template", "Help", "OVERVIEW", _
"Develop", "Schedule", "Information", "Announcements", _
"Summary")
Set shtsumm = Sheets("Summary")
Application.ScreenUpdating = False
shtsumm.Rows(4 & ":" & shtsumm.Rows.Count).Delete
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, arrExclude, 0)) Then
lastRow = sh.Cells(sh.Rows.Count, "L").End(xlUp).Row
For i = 14 To lastRow
Set rw = sh.Rows(i)
If rw.Cells(1, "Q").Value <> Empty And _
rw.Cells(1, "N").Value <> "Designer" And _
rw.Cells(1, "O").Value <> "Layouter" Then
NameDevice = rw.Range("Q1").Value
adressDevice = rw.Range("Q1").Value '<<<typo ?
'find destination
Set rng = shtsumm.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
rng.Value = sh.Name
'Here Range is relative to *rw*, not to the whole sheet
rw.Range("A1:E1,I1:O1,Q1,V1").Copy rng.Offset(0, 1)
rng.Resize(1, 15).Borders.LineStyle = xlContinuous
shtsumm.Hyperlinks.Add _
anchor:=rng.EntireRow.Cells(1, "N"), _
Address:="", SubAddress:="'" & sh.Name & "'!A1", _
TextToDisplay:=NameDevice
End If
Next
End If
Next
Application.ScreenUpdating = True
shtsumm.Activate
End Sub
Related
I want to select whole rows of a range (C14:M34) if value = 1 in a column(F14:F34). Otherwise I want to select the same rows except a specific column(G).
I can do this if I have only a single row but how can I apply this for a range (multiple rows)?
Hereby my code (which is not working):
ActiveSheet.Range("$C$13:$M$34").AutoFilter Field:=6, Criteria1:="<>"
Dim d As Range
For Each d In Range("F14:F34")
If d.Value = 1 Then
ActiveSheet.Range("C14:M34").Select
Else
Application.Union(Range("C14:F34"), Range("H14:M34")).Select
End If
Selection.Copy
Next d
Try this code, please:
Sub testSelecting()
Dim sh As Worksheet, rngSel As Range, i As Long
Set sh = ActiveSheet
For i = 14 To 34
If sh.Range("F" & i).Value = 1 Then
If rngSel Is Nothing Then
Set rngSel = sh.Range("C" & i & ":M" & i)
Else
Set rngSel = Union(rngSel, sh.Range("C" & i & ":M" & i))
End If
Else
If rngSel Is Nothing Then
Set rngSel = Union(sh.Range("C" & i & ":F" & i), sh.Range("H" & i & ":M" & i))
Else
Set rngSel = Union(rngSel, sh.Range("C" & i & ":F" & i), sh.Range("H" & i & ":M" & i))
End If
End If
Next i
If rngSel.Cells.count > 1 Then rngSel.Select: Stop
rngSel.Copy
End Sub
The code is not tested, because I do not have your file to do that. It is based only on logic. It stops after selection, in order to let you appreciate that the selected range is the one you need.
Please confirm that it works as you need, or what problem does it create, if any...
I have a data entry form that let's users enter the data into specific cells. What i want is a way to track changes to the cell values. When the data entered initially through the entry form, i don't want that information to be tracked. However, if the user tries to change/edit the data that was entered then i want to add a comment to show the initial value and the amended one as well.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim singlecell As Range
If Target.Cells.CountLarge > 1000 Then Exit Sub
For Each singlecell In Target
If singlecell.Comment Is Nothing Then
singlecell.AddComment Now & " - " & singlecell.Value & " - " & Environ("UserName")
Else
singlecell.Comment.Text _
vbNewLine & Now & " - " & singlecell.Value & " - " & Environ("UserName") _
, Len(singlecell.Comment.Text) + 1 _
, False
End If
singlecell.Comment.Shape.TextFrame.AutoSize = True
Next singlecell
End Sub
The code i tried adds a comment when the information from the entry form is submitted. However I don't need the comment to show just yet, I only want it when the user changes the initial cell value.
you can use a helper array to temporary store all of current cell comments and get the sensitive text out of the last recorded comment to compare with current cell content
Private Sub Worksheet_Change(ByVal Target As Range)
Dim singleCell As Range
Dim commentsArray As Variant 'array to hold all singleCell comments
Dim oldText As String ' string to hold last comment sensitive content
If Target.Cells.CountLarge > 1000 Then Exit Sub
For Each singleCell In Target
If singleCell.Comment Is Nothing Then
singleCell.AddComment Now & " - " & singleCell.Value & " - " & Environ("UserName")
Else
commentsArray = Split(singleCell.Comment.Text, vbNewLine) ' fill the array with current singleCell comments
oldText = CStr(Split(commentsArray(UBound(commentsArray)), " - ")(1)) ' extract last recorded comment sensitive text
'update comment if current cell value differs from last recorded comment sensitive text
If oldText <> CStr(singleCell.Value2) Then _
singleCell.Comment.Text _
vbNewLine & Now & " - " & singleCell.Value & " - " & Environ("UserName") _
, Len(singleCell.Comment.Text) + 1 _
, False
End If
singleCell.Comment.Shape.TextFrame.AutoSize = True
Next
End Sub
Copy and create the same table in same sheet, have it hidden ,
Sub CopyCurrentTable()
Application.ScreenUpdating = False
With shtMapping
.Range("E4:G1000").ClearContents 'which value to which value you are copying
.Range("B4:D" & GetLastRow(shtMapping, "B", 4)).Copy ' starting postion
.Range("E4").PasteSpecial xlPasteAll
Application.CutCopyMode = False
End With
End Sub
Sub LogAuditTrail()
Dim colOld As Collection
Dim colNew As Collection
Dim objNew As ClsMapping
Dim objOld As ClsMapping
Set colOld = getMappingData("E")
Set colNew = getMappingData("B")
Dim sTS As String
sTS = Format(Now, "dd-mmm-yyy hh:mm:ss")
For Each objNew In colNew
'Detect Items Changed
If ItemIsInCollection(colOld, objNew.getKey) Then
Set objOld = colOld(objNew.getKey)
If objNew.isDifferent(objOld) Then
Call PlotToAudit(objNew, objOld, sTS, "Change")
End If
Else
'Detect Items Added
Set objOld = New ClsMapping
Call PlotToAudit(objNew, objOld, sTS, "New")
End If
Next objNew
'Detect Items removed
For Each objOld In colOld
If Not ItemIsInCollection(colNew, objOld.getKey) Then
Set objNew = New ClsMapping
Call PlotToAudit(objNew, objOld, sTS, "Removed")
End If
Next objOld
End Sub
Sub PlotToAudit(obj1 As ClsMapping, obj2 As ClsMapping, sTS As String, sType As String)
Dim lRow As Long
lRow = shtAudit.Range("B1048576").End(xlUp).Row
If lRow = 3 Then
lRow = 5
ElseIf lRow = 1048576 Then
MsgBox "Audit sheet is full. Contact Support." & vbNewLine & "No audit trail will be saved", vbCritical, "ERROR"
Exit Sub
Else
lRow = lRow + 1
End If
With shtAudit
.Unprotect g_sPassword
.Range("B" & lRow).value = Application.UserName & "(" & Environ("USERNAME") & ")"
.Range("C" & lRow).value = sTS
.Range("D" & lRow).value = sType
Select Case sType
Case "Removed"
.Range("E" & lRow).value = ""
.Range("F" & lRow).value = ""
.Range("G" & lRow).value = ""
.Range("H" & lRow).value = obj2.FundCode
.Range("I" & lRow).value = obj2.Subs
.Range("J" & lRow).value = obj2.Reds
Case "New"
.Range("E" & lRow).value = obj1.FundCode
.Range("F" & lRow).value = obj1.Subs
.Range("G" & lRow).value = obj1.Reds
.Range("H" & lRow).value = ""
.Range("I" & lRow).value = ""
.Range("J" & lRow).value = ""
Case "Change"
.Range("E" & lRow).value = obj1.FundCode
.Range("F" & lRow).value = obj1.Subs
.Range("G" & lRow).value = obj1.Reds
.Range("H" & lRow).value = obj2.FundCode
.Range("I" & lRow).value = obj2.Subs
.Range("J" & lRow).value = obj2.Reds
End Select
With .Range("B" & lRow & ":J" & lRow)
.Interior.Color = vbWhite
.Borders.LineStyle = xlContinuou
End With
.Protect g_sPassword
End With
End Sub
I am trying to vlookup few columns from another sheet, and I am trying to dynamically set range for the vlookup table and then copy and paste the formula down to my lookup values sheet (which works)
Any Help would be great!
I tried the code below but it does not set value in FRow or SRow.
Sub test()
Dim FRow As Long
Dim SRow As Long
With Sheets("M2URPN")
Set FRow = Sheets("M2URPN").Cells(Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("M2URPN")
Set SRow = .sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
End With
If Worksheets("RECONCILE").Range("A2") Is Nothing Then
Worksheets("RECONCILE").Range("A2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("B2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & FRow & ",4,FALSE)"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Range("C2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & FRow & ",4,FALSE)"
Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
End With
End If
If Worksheets("RECONCILE").Range("E2") Is Nothing Then
Worksheets("RECONCILE").Range("E2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("F2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & SRow & ",4,FALSE)"
Range("F2:F" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
Range("G2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & SRow & ",3,FALSE)"
Range("G2:G" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
End With
End If
I fixed it as below:
Sub Vlookup()
Worksheets("RECONCILE").Activate
If Worksheets("RECONCILE").Range("A2") = "" Then
Worksheets("RECONCILE").Range("A2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("B2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & Sheets("M2URPN").Cells(Rows.Count, 1).End(xlUp).Row & ",4,FALSE)"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Range("C2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & Sheets("M2URPN").Cells(Rows.Count, 1).End(xlUp).Row & ",4,FALSE)"
Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Worksheets("RECONCILE").Range("B1").Value = "Amount"
Worksheets("RECONCILE").Range("C1").Value = "Customer Account"
End With
End If
If Worksheets("RECONCILE").Range("E2") = "" Then
Worksheets("RECONCILE").Range("E2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("F2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & Sheets("M2URPN").Cells(Rows.Count, 7).End(xlUp).Row & ",4,FALSE)"
Range("F2:F" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
Range("G2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & Sheets("M2URPN").Cells(Rows.Count, 7).End(xlUp).Row & ",3,FALSE)"
Range("G2:G" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
Worksheets("RECONCILE").Range("F1").Value = "Amount"
Worksheets("RECONCILE").Range("G1").Value = "Customer Account"
End With
End If
Worksheets("RECONCILE").Columns(2).NumberFormat = "0"
Worksheets("RECONCILE").Columns(7).NumberFormat = "0"
Range("A1:L1").Font.Bold = True
For Each sht In ThisWorkbook.Worksheets
sht.Cells.EntireColumn.AutoFit
Next sht
End Sub
New to VBA, I've pieced together the below code which makes changes to certain cells based upon activity in Column.
I split the actions into modules to make it easier to follow but now this only works when the change in column is copy/pasted (the macro does not work if I type into the column instead).
Any ideas what I'm missing?
The Sheet Code
Option Explicit
'Event Macro to put formulas in A, B and D if C changes
Private Sub Worksheet_Change(ByVal Target As Range) ' Every Change on this sheet do this code
Dim lRow As Long
Dim cell As Range
Dim CKeyCells As Range
' Set SelectionColumn range
Set CKeyCells = Range("$C$3:$C$1048576")
If Not Intersect(Target, Columns(3)) Is Nothing Then 'If the Change wasn't in Column
CbuddyMacro
End If
End Sub
The Module/Macro Code
Public Sub CbuddyMacro()
Dim lRow As Long
Dim cell As Range
Dim selectedRange As Range
Set selectedRange = Application.Selection
For Each cell In selectedRange
If cell.Value <> "" Then 'If Col has something in it then do the following.
lRow = cell.Row 'Get the current row
Cells(cell.Row, "A").Formula = "=IF(ISBLANK(I" & lRow & "),"""",I" & lRow & ")"
Cells(cell.Row, "B").Formula = "=IF(ISBLANK(J" & lRow & "),"""",J" & lRow & ")"
Cells(cell.Row, "D").Formula = "=IF(ISBLANK(K" & lRow & "),"""",K" & lRow & ")"
Cells(cell.Row, "E").Formula = "=IFERROR(INDEX(Database!$E$3:$E$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),"""")"
Cells(cell.Row, "F").Formula = "=IFERROR(IF(ISBLANK(INDEX(Database!$F$3:$F$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),INDEX(Database!$P$3:$P$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),INDEX(Database!$F$3:$F$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),"""")"
Cells(cell.Row, "G").Formula = "=IFERROR(IF(ISBLANK(INDEX(Database!$G$3:$G$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),INDEX(Database!$Q$3:$Q$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),INDEX(Database!$G$3:$G$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),"""")"
Cells(cell.Row, "H").Formula = "=IF(ISBLANK(L" & lRow & "),"""",L" & lRow & ")"
Cells(cell.Row, "I").Formula = "=IFERROR(TEXT(LOOKUP(2,1/($M$" & lRow & ":$AP$" & lRow & "<>""""),$M$" & lRow & ":$AP$" & lRow & "),""DD-MMM-YY""),"""")"
Cells(cell.Row, "J").Formula = "=IFERROR(TEXT(LOOKUP(2,1/($BU$" & lRow & ":$CX$" & lRow & "<>""""),$BU$" & lRow & ":$CX$" & lRow & "),""DD-MMM-YY""),"""")"
Cells(cell.Row, "K").Formula = "=IFERROR(LOOKUP(2,1/($AQ$" & lRow & ":$BT$" & lRow & "<>""""),$AQ$" & lRow & ":$BT$" & lRow & "),"""")"
Cells(cell.Row, "L").Formula = "=IFERROR(LOOKUP(2,1/($CY$" & lRow & ":$EB$" & lRow & "<>""""),$CY$" & lRow & ":$EB$" & lRow & "),"""")"
End If
If cell.Value = "" Then 'If Col has nothing in it then do the following.
Cells(cell.Row, "A").Formula = ""
Cells(cell.Row, "B").Formula = ""
Cells(cell.Row, "D").Formula = ""
Cells(cell.Row, "E").Formula = ""
Cells(cell.Row, "F").Formula = ""
Cells(cell.Row, "G").Formula = ""
Cells(cell.Row, "H").Formula = ""
Cells(cell.Row, "I").Formula = ""
Cells(cell.Row, "J").Formula = ""
Cells(cell.Row, "K").Formula = ""
Cells(cell.Row, "L").Formula = ""
End If
Next cell
I am trying to combine a vlookup formula with an If condition. To be more exact, I have a worksheet where I want a vlookup formula to be executed in the cell of the column G if the cell of the column E AND F is 0. Just to be clear, the variable lastrow3 and ws1 are WELL defined and have proper values. Also, I have run the code without the if condition (just the vlookup) and it runs just fine. So there is no chance that there is an issue with these variables. Moreover, I want the vlookup to be dynamic. I have written 4 different types of code. I am providing them below.
CODE1
For i = 2 To lastrow3
ws1.Range("G" & i).Formula = "=IF(E" & i & "+ F" & i & " = 0, " & Chr(34) & "VLOOKUP(C"&i&",'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE)" & Chr(34) & ", " & Chr(34) & "No" & Chr(34) & ")"
Next i
This code gives me an error in this part: "VLOOKUP(C"&i&",saying that there is a syntax error.
CODE2
For Each cell In ws1.Range("G2:G" & lastrow3)
If cell.Offset(0, -1).Value = 0 Then
If cell.Offset(0, -2).Value = 0 Then
cell.Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
End If
End If
Next cell
This code gives an error in this part: If cell.Offset(0, -1).Value = 0 Then saying that there is type mismatch. Also, this code does not have dynamic vlookup, so it vlookups only for cell C2.
CODE3
With ws1
For i = 2 To lastrow3
If .Cells(i, "E").Value2 = 0 And .Cells(i, "F").Value2 = 0 Then
.Cells(i, "G").Formula = "=IFERROR(VLOOKUP($C$" & i&",'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
End If
Next cell
End With
This code gives me an error in this part : .Cells(i, "G").Formula = "=IFERROR(VLOOKUP($C$" & i&",'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")" saying the there is a syntax error.
CODE4
With ws1
.Range("G2:G" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
.Range("G2:G" & lastrow3).Value = .Range("G2:G" & lastrow3).Value
End With
This code runs fine (this is the code I ran and verified that the variables are well defined) bit does not include the If condition.
I want to declare that this code runs really fast (with the With ws1 and End With) so if it is possible to make this code ran by adding the if condition then it would be perfect.
CODE5 (-> my attempt at adding If condition in CODE4)
With ws1
If .Range("G2:G" & lastrow3).Offset(0, -1).Value = 0 And .Range("G2:G" & lastrow3).Offset(0, -2).Value = 0 Then
.Range("G2:G" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
End If
.Range("G2:G" & lastrow3).Value = .Range("G2:G" & lastrow3).Value
End With
This code gives me an error in this part : If .Range("G2:G" & lastrow3).Offset(0, -1).Value = 0 And .Range("G2:G" & lastrow3).Offset(0, -2).Value = 0 Then saying that there is an type mismatch.
SUMMARY
I am trying to combine speed and accuracy in the code. The code with the With and End With, from what I have searched, is the fastest. However, If I manage to solve it with another code then no issue. The main errors I get is in the vlookup formula, when I try to make it dynamic and in the if condition, when I try to find whether the offsets have 0 values.
I am adding the entire code so far (although I think it is not important)
ENTIRE CODE
Sub Pharma_Stock_Report()
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim CopyRange As Range
Dim i As Long
spath1 = Application.ThisWorkbook.Path & "\Pharma replenishment.xlsm"
spath2 = Application.ThisWorkbook.Path & "\NOT OK.xlsx"
Workbooks.Open spath1
Workbooks.Open spath2
Set ws1 = Workbooks("Pharma Stock Report.xlsm").Worksheets("Pharma Stock Report")
Set ws2 = Workbooks("Pharma replenishment.xlsm").Worksheets("Replenishment")
Set ws3 = Workbooks("NOT OK.xlsx").Worksheets("Sheet1")
With ws1
.Cells.Clear
End With
With ws2
lastrow1 = .Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To lastrow1
If .Cells(i, "D").Interior.ColorIndex = -4142 Or .Cells(i, "D").Interior.ColorIndex = 2 Then
If CopyRange Is Nothing Then
Set CopyRange = .Range("A" & i & ":F" & i)
Else
Set CopyRange = Union(CopyRange, .Range("A" & i & ":F" & i))
End If
End If
Next i
End With
CopyRange.Copy
With ws1.Range("A2")
.PasteSpecial xlPasteValues
End With
ws2.Range("A4:F4").Copy
With ws1.Range("A1")
.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
Workbooks("Pharma replenishment.xlsm").Close
ws3.Range("I1").Copy
With ws1.Range("G1")
.PasteSpecial xlPasteValues
End With
lastrow3 = ws1.Range("D" & Rows.Count).End(xlUp).Row
With ws1
.Range("G2:G" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
.Range("G2:G" & lastrow3).Value = .Range("G2:G" & lastrow3).Value
End With
Application.CutCopyMode = False
Workbooks("NOT OK.xlsx").Close
With ws1.Range("A1:G" & lastrow3)
.HorizontalAlignment = xlCenter
.Font.Color = vbBlack
.Font.Name = "Calibri"
.Font.Italic = False
.Borders.LineStyle = xlDouble
.Borders.Weight = xlThin
.Borders.Color = vbBlack
End With
With ws1.Range("A1:G1")
.Interior.ColorIndex = 41
.Font.Bold = True
.Font.Size = 14
.Font.Italic = True
End With
With ws1.Range("A1", Range("A1").End(xlDown).End(xlToRight))
.EntireColumn.AutoFit
End With
ws1.Range("A1:G1").AutoFilter
ws1.AutoFilter.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws1.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
CODE1 has some issues. You've inserted some Chr(34) around the VLOOKUP and unless you want the cell to display the lookup formula, instead of the result of the lookup then they need to go.
ws1.Range("G" & i).Formula = "=IF(E" & i & "+ F" & i & " = 0, " & "VLOOKUP(C" & i & ",'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE)" & ", " & Chr(34) & "No" & Chr(34) & ")"
To blank out zeros and #N/A -
ws1.Range("G" & i).Formula = "=IFNA(IF(E" & i & "+ F" & i & " = 0, " & "IF(IFNA(VLOOKUP(C" & i & ",'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),0)=0,"""",IFNA(VLOOKUP(C" & i & ",'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),0))" & ", " & Chr(34) & "No" & Chr(34) & "),"""")"
The first code is an easy fix: there actually is a syntax error, as vba requires spaces between variable names and the &-Operator. Adding spaces like
ws1.Range("G" & i).Formula = "=IF(E" & i & "+ F" & i & " = 0, " & Chr(34) & "VLOOKUP(C" & i & ",'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE)" & Chr(34) & ", " & Chr(34) & "No" & Chr(34) & ")"
will solve that problem.
Your current code is testing a range of values which is likely why you are getting type issues
Instead it would be easier to add the if test in the formula (Then using R1C1 notation to create referenced lookups)
.Range("G2:G" & lastrow3).FormulaR1C1 = "=IF(AND(RC[-2]=0,RC[-1]=0),IFERROR(VLOOKUP(RC[-4],'[NOT OK.xlsx]Sheet1'!C[-1]:C[2],4,FALSE),""""),"Null Values")"