I can't make the error go away, it only turns into a different error. The IF at the top is ended. The FORs all align. If I add an 'End IF' before "End Sub", I get the error "for without next".
Here is my code:
Sub Updatevalue()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
wbname1 = Range("IllustWBDir1")
Set wb1 = Application.Workbooks.Open(wbname1)
ThisWorkbook.Activate
For Item = 0 To Sheets("Documentation").ListBox1.ListCount - 1
If Sheets("Documentation").ListBox1.Selected(Item) = True Then
If Sheets("Documentation").ListBox1.List(Item) = "Compact" Then
Range("Statename") = "MA"
stname = "C"
Else
Range("Statename") = Sheets("Documentation").ListBox1.List(Item)
stname = Range("Statename")
End If
Range("Statename").Copy
wb1.Activate
Sheets("Inputs").Select
Range("State").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Calculate
Set ws1 = wb1.Sheets("PPGs")
Set tb1 = ws1.Range("PPG_Table")
ThisWorkbook.Activate
Base_Schematic = ThisWorkbook.Names("Base_Schematic").RefersToRange
' Key Ages
Dim ages(1 To 8) As String
ages(1) = "30"
ages(2) = "40"
ages(3) = "50"
ages(4) = "55"
ages(5) = "60"
ages(6) = "65"
ages(7) = "70"
ages(8) = "75"
' Gender
Dim uniorgd(1 To 3) As String
uniorgd(1) = "U"
uniorgd(2) = "F"
uniorgd(3) = "M"
' Bps
Dim Bps(1 To 6) As String
Bps(1) = "1"
Bps(2) = "2"
Bps(3) = "3"
Bps(4) = "4"
Bps(5) = "5"
Bps(6) = "6"
' UW Classes
Dim UWs(1 To 4) As String
UWs(1) = "P"
UWs(2) = "S"
UWs(4) = "1"
UWs(5) = "2"
' Marital Status
Dim Mar(1 To 2) As String
Mar(1) = "S"
Mar(2) = "M"
' Inflations
Dim Infls(1 To 2) As String
Infls(1) = "3C_PPG"
Infls(2) = "5C_PPG"
For a = 1 To 8
For b = 1 To 3
For c = 1 To 6
For d = 1 To 4
For e = 1 To 2
For f = 1 To 2
findval = ages(a) & uniorgd(b) & Bps(c) & UWs(d) & Mar(e) & Infls(f)
wb1.Activate
Sheets("PPGs").Select
pasteval = Application.WorksheetFunction.VLookup(Right(findval, 10), Range("PPG_Table"), Range("2,84"), False)
Next f
Next e
Next d
Next c
Next b
Next a
End Sub
You seem to be missing Next for the first For and End If for the First If
since you understand the logic, you should be able to place them appropriately.
Sub Updatevalue()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
wbname1 = Range("IllustWBDir1")
Set wb1 = Application.Workbooks.Open(wbname1)
ThisWorkbook.Activate
For Item = 0 To Sheets("Documentation").ListBox1.ListCount - 1
If Sheets("Documentation").ListBox1.Selected(Item) = True Then
If Sheets("Documentation").ListBox1.List(Item) = "Compact" Then
Range("Statename") = "MA"
stname = "C"
Else
Range("Statename") = Sheets("Documentation").ListBox1.List(Item)
stname = Range("Statename")
End If
Range("Statename").Copy
wb1.Activate
Sheets("Inputs").Select
Range("State").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Calculate
Set ws1 = wb1.Sheets("PPGs")
Set tb1 = ws1.Range("PPG_Table")
ThisWorkbook.Activate
Base_Schematic = ThisWorkbook.Names("Base_Schematic").RefersToRange
' Key Ages
Dim ages(1 To 8) As String
ages(1) = "30"
ages(2) = "40"
ages(3) = "50"
ages(4) = "55"
ages(5) = "60"
ages(6) = "65"
ages(7) = "70"
ages(8) = "75"
' Gender
Dim uniorgd(1 To 3) As String
uniorgd(1) = "U"
uniorgd(2) = "F"
uniorgd(3) = "M"
' Bps
Dim Bps(1 To 6) As String
Bps(1) = "1"
Bps(2) = "2"
Bps(3) = "3"
Bps(4) = "4"
Bps(5) = "5"
Bps(6) = "6"
' UW Classes
Dim UWs(1 To 4) As String
UWs(1) = "P"
UWs(2) = "S"
UWs(4) = "1"
UWs(5) = "2"
' Marital Status
Dim Mar(1 To 2) As String
Mar(1) = "S"
Mar(2) = "M"
' Inflations
Dim Infls(1 To 2) As String
Infls(1) = "3C_PPG"
Infls(2) = "5C_PPG"
For a = 1 To 8
For b = 1 To 3
For c = 1 To 6
For d = 1 To 4
For e = 1 To 2
For f = 1 To 2
findval = ages(a) & uniorgd(b) & Bps(c) & UWs(d) & Mar(e) & Infls(f)
wb1.Activate
Sheets("PPGs").Select
pasteval = Application.WorksheetFunction.VLookup(Right(findval, 10), Range("PPG_Table"), Range("2,84"), False)
Next f
Next e
Next d
Next c
Next b
Next a
End If
Next
End Sub
This is one of the good reason to properly indent your code !
The first For and the first If have no Next and End If.
One way to avoid this kind of problems is to write the end statement right after you write the conditions statement, and then you move inside the cicle and write the code.
Related
I am struggling with the error subscript out of range at the code:
Set wsCondition = wbCondition.Worksheets(2)
This code is run very well on windows but when I try on MacOS the error occurs. I am a newbie to VBA and I completely do not understand why this error occurs.
Thanks in advance for your guys advice.
Option Explicit
Public Sub btn1_Click()
Dim i As Double
Dim N As Double
Dim strKeyWord As String
Dim myCount As Integer
Dim OrderCount As Integer
Dim SubTotal As Range, Country As Range, DisCount As Range, Quantity As Range, ItemName As Range, OrderName As Range, RequiredData As Range
Dim wsOrder As Worksheet
Dim wsResult As Worksheet
Dim wsCondition As Worksheet
Dim wbOrder As Workbook
Dim wbCondition As Workbook
Dim OrderFile As String
Dim ConditionFile As String
'Open Order wb
OrderFile = Application.GetOpenFilename()
Set wbOrder = Workbooks.Open(OrderFile)
Set wsOrder = wbOrder.Worksheets(1)
'Open Condition wb
ConditionFile = Application.GetOpenFilename()
Set wbCondition = Workbooks.Open(ConditionFile)
Set wsCondition = wbCondition.Worksheets(2)
Set wsResult = wbCondition.Worksheets(1)
With wsResult
.Range("A1").Value = "Product code"
.Range("B1").Value = "Order Condition"
.Range("C1").Value = "Order Name"
.Range("D1").Value = "Subtotal"
.Range("E1").Value = "Discount"
.Range("F1").Value = "Quantity"
.Range("G1").Value = "Item Name"
.Range("H1").Value = "Country"
.Range("A1").Characters(1, 12).Font.Bold = True
.Range("B1").Characters(1, 16).Font.Bold = True
.Range("C1").Characters(1, 16).Font.Bold = True
.Range("D1").Characters(1, 12).Font.Bold = True
.Range("E1").Characters(1, 12).Font.Bold = True
.Range("F1").Characters(1, 12).Font.Bold = True
.Range("G1").Characters(1, 12).Font.Bold = True
.Range("H1").Characters(1, 12).Font.Bold = True
.Range("A1").WrapText = True
.Range("B1").WrapText = True
.Range("C1").WrapText = True
.Range("D1").WrapText = True
.Range("E1").WrapText = True
.Range("F1").WrapText = True
.Range("G1").WrapText = True
.Range("H1").WrapText = True
.Range("A1").ColumnWidth = 13
.Range("A1").RowHeight = 17
.Range("B1").ColumnWidth = 12
.Range("B1").RowHeight = 17
.Range("C1").ColumnWidth = 14.5
.Range("C1").RowHeight = 17
.Range("G1").ColumnWidth = 99
.Range("G1").RowHeight = 17
End With
'using the CountA ws function (all non-blanks)
myCount = Application.CountA(wsCondition.Range("A:A"))
For i = 2 To myCount Step 1
strKeyWord = wsCondition.Range("A" & i)
wsOrder.Range("R:R").AutoFilter Field:=1, Criteria1:="=*" & strKeyWord & "*"
If wsOrder.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
Set SubTotal = wsOrder.Range("I2", wsOrder.Range("I" & Rows.Count).End(xlUp))
Set Country = wsOrder.Range("AG2", wsOrder.Range("AG" & Rows.Count).End(xlUp))
Set DisCount = wsOrder.Range("N2", wsOrder.Range("N" & Rows.Count).End(xlUp))
Set Quantity = wsOrder.Range("Q2", wsOrder.Range("Q" & Rows.Count).End(xlUp))
Set OrderName = wsOrder.Range("A2", wsOrder.Range("A" & Rows.Count).End(xlUp))
Set ItemName = wsOrder.Range("R2", wsOrder.Range("R" & Rows.Count).End(xlUp))
Set RequiredData = Union(SubTotal, Country, DisCount, Quantity, OrderName, ItemName)
RequiredData.SpecialCells(xlCellTypeVisible).Copy
OrderCount = wsOrder.Range("A2", wsOrder.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells.Count
With wsResult
If OrderCount >= 2 Then
For N = 1 To OrderCount Step 1
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "Available"
Next N
Else
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "Available"
End If
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).PasteSpecial
End With
Else
With wsResult
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "No Order"
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).Value = "N/A"
.Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "N/A"
.Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = "N/A"
End With
End If
OrderCount = 0
Next i
wbCondition.Sheets("Result").Activate
wsOrder.AutoFilterMode = False
End Sub
This has nothing to do whether this code is running on a Mac or Win environment. You have to check if a second worksheet exists in the file you open. In your case you could add following code
If wbCondition.Worksheets.Count > 1 Then
Set wsCondition = wbCondition.Worksheets(2)
else
' Do sth in order to fix the error or end the sub
end if
If you get a subscript out of range it means you tried to access a worksheet that doesn’t exist. This may happen for the following reasons
The worksheet name given to Worksheets is spelled incorrectly.
The name of the worksheet has changed. The worksheet was deleted.
The index was to large e.g. You used Worksheets(5) but there are only four worksheets
The wrong workbook is being used e.g. Workbooks(“book1.xlsx”).Worksheets(“Sheet1”) instead of Workbooks(“book3.xlsx”).Worksheets(“Sheet1”)
You find this here
My problem is stated in the title. The error occurs in the first line with .Copy, but I have had it the same as the second one and received the same error.
I have checked so that the Sheet names are correct, and even copied them straight from the Sheet title in case some weird character sneaked in.
I'll put snippets of code here and then the full code in the end in case the problem is something different.
Declaration:
(I have tried setting it explicitly with Workbooks() but it didn't help)
Dim wb As Workbook
Set wb = ThisWorkbook' Or Workbooks("collected.xlsm")
Dim sUser As Worksheet, sExceptions As Worksheet
Set sUser = wb.Sheets("User")
Set sExceptions = wb.Sheets("Exceptions")
Copying:
sUser.Range(Cells(rS, 1)).Copy Destination:=sExceptions.Range(Cells(Count, 1))
sUser.Range(rS, 11).Copy Destination:=sExceptions.Range(Count, 2)
Entire code:
Option Explicit
Function FindExceptions()
' To run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Variable def
Dim Count As Integer
' Variable def
' Worksheets
Dim wb As Workbook
Set wb = ThisWorkbook ' Or Workbooks("collected.xlsm")
Dim sUser As Worksheet, sVCD As Worksheet, sFullExport As Worksheet
Set sUser = wb.Sheets("User")
Set sVCD = wb.Sheets("VCD")
Set sFullExport = wb.Sheets("FullExport")
' r, f, c = Search, Find, Check
' For Each rows
Dim rS As Integer, rF As Integer, rC As Integer
'Set rS = sUser.Columns("A")
'Set rF = sVCD.Columns("A")
'Set rC = sFullExport("B")
' Vars used in execution
'Dim cS As Range, cF As Range, cC As Range
Dim secId As String, employeeNum As String, FoundVCD As Boolean, FoundFullExport As Boolean
' Go through User sheet
For rS = 2 To sUser.UsedRange.Rows.Count
secId = sUser.Cells(rS, "A").Value
employeeNum = sUser.Cells(rS, "K").Value
' Search for in VCD
FoundVCD = False
For rF = 2 To sVCD.UsedRange.Rows.Count
If sVCD.Cells(rF, "A").Value = secId And sVCD.Cells(rF, "K").Value = employeeNum Then
FoundVCD = True
Exit For
End If
Next
'Search for in Full Export?
If FoundVCD = True Then
FoundFullExport = False
For rC = 2 To sFullExport.UsedRange.Rows.Count
If sFullExport.Cells(rC, "B").Value = secId Then
FoundFullExport = True
Exit For
End If
Next
End If
If FoundFullExport = False Then
' WriteExceptions sUser.Cells(rS, "A").Value, sUser.Cells(rS, "K").Value, sFullExport.Cells(rC, "A").Value, sFullExport.Cells(rC, "D").Value
' Worksheet var
Dim sExceptions As Worksheet
Set sExceptions = wb.Sheets("Exceptions")
If Count = Null Or Count = 0 Then
sExceptions.Cells(1, "A") = "Säk. Id"
sExceptions.Cells(1, "B") = "Anst. Nr"
sExceptions.Cells(1, "C") = "Unison Id"
sExceptions.Cells(1, "D") = "Kort hex"
Count = 2
Else
Count = Count + 1
End If
' secId on col A, employeeNum on col B, unisonId on col C, cardHex on col D
sUser.Range(Cells(rS, 1)).Copy _
Destination:=sExceptions.Range(Cells(Count, 1))
sUser.Range(rS, 11).Copy _
Destination:=sExceptions.Range(Count, 2)
sFullExport.Range(rC, 1).Copy _
Destination:=sExceptions.Range(Count, 3)
sFullExport.Range(rC, 4).Copy _
Destination:=sExceptions.Range(Count, 4)
End If
Next
Count = 0
' To end settings to run faster
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function
You're confusing Range and Cells.
Try
sUser.Cells(rs, 1).Copy _
Destination:=sExceptions.Cells(count, 1)
sUser.Cells(rs, 11).Copy _
Destination:=sExceptions.Cells(count, 2)
sFullExport.Cells(rC, 1).Copy _
Destination:=sExceptions.Cells(count, 3)
sFullExport.Cells(rC, 4).Copy _
Destination:=sExceptions.Cells(count, 4)
I am generating a new workbook from a multiple workbooks, i can generate a summary of all the errors found, but when i try to copy the sheets with the error information i got the runtime error 9
These is the line failing
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
Other thing i havent add is that all the sheets on the multiple files have the same names, so i want to know if there is a way that the sheet when is copy i can add the file name and the sheet name
Sub getViolations()
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Filename = Dir(Path & "*.xls")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Dim wc As Worksheet
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = ActiveWorkbook.Sheets("Violations Summary").Range("B1")
ws.Cells(i, 2).Value = ActiveWorkbook.Sheets("Violations Summary").Range("C1")
Dim count As Integer
count = 15
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exits As Boolean
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (ActiveWorkbook.Sheets("Violations Summary").Cells(n, 2)) < 0 Then
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
End If
If IsEmpty(wc.Cells(n, 2)) Then
ws.Cells(i, n).Value = ["NA"]
End If
count = count + 1
Next n
Workbooks(Filename).Close
Filename = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
Put option explicit at top so spelling of variables is checked and that they are declared. The variable exists was mispelt and there were a number of other variables not declared. I have put some other comments in with the code.
Some of the logic i think can be simplified and i have given some examples. Also, ensure consistent use of named variable wc. If nothing else it should be easier to debug now. Compiles on my machine so give it a try.
This all works on the assumption that each workbook you open has the "Violations Summary" sheet and it is spelt as shown.
You have the filename already stored in the variable Filename so you can use (concatenate?) that with the sheetname variable.
Option Explicit 'Set this to ensure all variable declared and consistent spelling
'Consider using WorkSheets collection rather than Sheets unless you have chart sheets as well?
Sub getViolations()
Dim Path As String 'Declare you other variables
Dim FileName As String
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
FileName = Dir(Path & "*.xls")
Dim ws As Worksheet
Dim TxtRng As Range 'Declare this
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While FileName <> ""
Workbooks.Open FileName:=Path & FileName, ReadOnly:=True
Dim wc As Worksheet 'Consider whether to place these declarations just before the loop, avoids risk others may think there will be reinitialization even though there isn't
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = wc.Range("B1") 'Use the wc variable
ws.Cells(i, 2).Value = wc.Range("C1")
Dim count As Integer
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exists As Boolean 'Corrected spelling
count = 15
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists Then 'Shortened by removing = True (evaluates in same way)
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) < 0 Then 'used wc variable
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
Else 'Simplified this as if is not empty then is empty so can use else
ws.Cells(i, n).Value = ["NA"] 'what is pupose of square brackets? These can be removed i think
End If
count = count + 1
Next n
Workbooks(FileName).Close
FileName = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
Dim Sheet As Worksheet ' declare
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
After you copy the ActiveWorkbook.Sheets(sheetName) to ThisWorkbook, ThisWorkbook becomes the ActiveWorkbook. ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1) should not throw an error but will probably cause ActiveWorkbook.Sheets("Violations Summary") to fail. For this reason, you should always fully qualify your references.
Some idealist programmers say that a subroutine should perform 1 simply task. Personally, I believe that if you have to scroll up, down, left or right to see what your code is doing it is time to refactor it. When refactoring I try to extract logical groups of tasks in a separate subroutine. This makes debugging and modifying the code far easier.
Refactored Code
Option Explicit
Sub getViolations()
Const Path As String = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Dim n As Long
Dim Filename As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Sheet1Setup ws
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
ProcessWorkbook Filename, ws.Rows(n)
Filename = Dir()
Loop
End Sub
Sub ProcessWorkbook(WBName As String, row As Range)
Dim nOffset As Long, n As Long
Dim sheetName As String
Dim WB As Workbook
Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
With WB.Sheets("Violations Summary")
row.Columns(1).Value = .Range("B1")
row.Columns(2).Value = .Range("C1")
nOffset = 12
For n = 3 To 14
If .Cells(n, 2) = "" Then
row.Columns(n).Value = ["NA"]
ElseIf (.Cells(n, 2)) = 0 Then
row.Columns(n).Font.ColorIndex = 4
row.Columns(n).Font.ColorIndex = 0
ElseIf (.Cells(n, 2)) = 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
'Range.Parent refers to the ranges worksheet. row.Parent refers to ThisWorkbook.Sheets(1)
If SheetExists(WB, sheetName) Then .Copy After:=row.Parent.Sheets(1)
row.Columns(n + nOffset) = .Cells(1, n).Value
row.Columns(n).Font.ColorIndex = 3
row.Columns(n).Value = .Cells(n, 2)
End If
Next
End With
WB.Close SaveChanges:=False
End Sub
Function SheetExists(WB As Workbook, sheetToFind As String) As Boolean
Dim ws As Worksheet
For Each ws In WB.Worksheets
If sheetToFind = ws.Name Then
SheetExists = True
Exit Function
End If
Next
End Function
Sub Sheet1Setup(ws As Worksheet)
With ws.Range("A1:N1")
.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
.Font.ColorIndex = 2
.Interior.ColorIndex = 5
.HorizontalAlignment = xlCenter
End With
End Sub
Note: row is the target Row of ThisWorkbook.Sheets(1). row.Columns(3) is a fancy way to write row.Cells(1, 3) which refers to the 3rd cell in the target row. Also note that Cells, Columns, and Rows are all relative to the range they belong to. e.g. Range("C1").Columns(2) refers to D1, Range("C1").Rows(2).Columns(2) refers to D2, Range("C1").Cells(2,2) also refers to D2.
My goal: I need to be able to take two different worksheets from different workbooks and combine them into one workbooks with two worksheets (already completed). One of the worksheets will be from older data and be used as a masterlist, while the other worksheet will contain the older data along with new data (and changes to old data). I need to be able to get rid of the old data already on the masterlist but still check to see if there is any changes in the older data (the information will be deleted from the new information worksheet). The end goal is to have two worksheets: 1 contains the old information (already done) and 1 contains the new information and any changes to the new information (need help with).
What I have now:
Sub DocumentInspector()
Dim RowCount As Integer
Dim Row As Integer
Dim Column As Integer
Dim ColumnCount As Integer
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim i As Integer
Dim count As Integer
Dim count2 As Integer
count2 = 0
i = 0
count = 0
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "F:\ \Document Inspector" ' change to suit
Set wbDst = Workbooks("DocumentInspector.xlsm")
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.count)
strFilename = Dir()
Loop
wbDst.Worksheets(2).Name = "Old Information"
wbDst.Worksheets(3).Name = "New Information"
'MUST CHANGE RANGES
RowCount = Sheets("New Information").UsedRange.Rows.count
ColumnCount = Sheets("New Information").UsedRange.Columns.count
'MUST CHANGE RANGE
For Each x In Sheets("Old Information").Range("A1:E10")
For Row = 2 To RowCount
For Column = 1 To ColumnCount
If x.Value = Sheets("New Information").Cells(Row, Column).Value Then
Sheets("New Information").Cells(Row, Column).Interior.Color = RGB(255, 255, 0)
End If
Next Column
Next Row
Next
For Row = 2 To RowCount
For Column = 1 To ColumnCount
If Sheets("New Information").Cells(Row, Column).Interior.Color = RGB(255, 255, 0) Then
Sheets("New Information").Cells(Row, Column).Interior.Color = xlNone
count = count + 1
Else
Sheets("New Information").Cells(Row, Column).Interior.Color = RGB(255, 255, 0)
count2 = count2 + 1
End If
Next Column
If count = ColumnCount Then
Sheets("New Information").Rows(Row).EntireRow.Interior.Color = xlNone
Sheets("New Information").Rows(Row).EntireRow.Delete
Row = Row - 1
ElseIf count2 = ColumnCount Then
Sheets("New Information").Rows(Row).EntireRow.Interior.Color = xlNone
Sheets("New Information").Rows(Row).EntireRow.Delete
End If
count2 = 0
count = 0
Next Row
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Try this,
I have done with formulas, you can do the same in VBA too dynamically.
It can be one solution but there may be better than this.
refer the image below.
It is simple match and concatenate.
Example of what I need to be able to do:
Worksheet 1 "Old Information"
A B C D
E F G H
Worksheet 2 "New Information"
A B C D
E F J H
Runs Code....
Worksheet 1 "Old Information"
A B C D
E F G H
Worksheet 2 "New Information"
E F J H (with J highlighted)
I have five worksheet in all that are using the below code which is stored in a workbook. The first worksheet works perfectly well with the code. The second spreadsheet can check for the first item before returning the error. The subsequent third and fourth worksheet return the error immediately. The fifth worksheet on the other hand return error 400. May I know is my code the source of the problem or it's the checkbox because I copied and paste from the first worksheet.
Sub test5()
Dim MyFile As String
Dim FinalRow As Long
Dim Row As Long
Dim i As Integer
Dim d As Integer
d = 2
i = 0
FinalRow = Cells(Rows.count, "S").End(xlUp).Row
For Row = 3 To FinalRow
If Not IsEmpty(ActiveSheet.Cells(Row, "S")) Then
i = i + 1
d = d + 1
MyFile = ActiveSheet.Cells(Row, "S").Value
If Dir(MyFile) <> "" Then
ActiveSheet.OLEObjects("CheckBox" & i). _
Object.Value = True ' <~~~~~~~~~~~~~~~~ Error occurs here
With ActiveSheet.Cells(d, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
'If (ActiveSheet.Cells(d, "F") - ActiveSheet.Cells(d, "G") >= 0) Then
' ActiveSheet.Cells(d, "F").Font.Color = vbRed
'End If
If (.Value - .Offset(0, 1).Value) >= 0 Then
.Font.Color = vbRed
Else
.Font.Color = vbBlack
End If
End With
' i = i + 1
'd = d + 1
End If
End If
Next
End Sub
The program terminates after stepping into this line of code:
ActiveSheet.OLEObjects("CheckBox" & i). _ Object.Value = True
OLEObject does not have a member called value. If you are trying to display the OLEObject, use visible instead
ActiveSheet.OLEObjects("CheckBox" & i).Visible = True
See all OLEObject members here :
OLEObject Object Members