Related
Thank you for see this question.
Due to my bad communication, my previous posts could not tell what my purpose was.
My goal is, to split this range
Set rng = Application.Intersect(Target, Me.Range("M31:AM53"))
to different ranges, I created calendar style schedule sheets, so it requires
at least non adjacent 42 ranges.
Below code shows my image of that 42 different ranges(insert "1" is its range)
I want change cell interior color dynamically.
Sub WriteNumber_v4()
Dim rng As Range
Dim i, j As Integer
For i = 1 To 6
For j = 1 To 7
Set rng = Range("M31:O33").Offset((i - 1) * 4, (j - 1) * 4)
rng.Value = 1
Next j
Next i
End Sub
Thankfully, many people answered me. Those helped me a lot.
I hope you would help and enlighten me again.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim trlRed As Long, sPhoneYellow As Long, adrBlue As Long, iosGrey As Long, cmnPurple As Long
Dim rng As Range, cell As Range
trlRed = RGB(230, 37, 30)
aaaPhoneYellow = RGB(255, 234, 0)
adrGreen = RGB(126, 199, 216)
iosGrey = RGB(162, 170, 173)
cmnPurple = RGB(165, 154, 202)
'firstLvValFor = Array("Trial, "Basic", "Novice", "Intermediate", "Advanced")
secondLvValFor = Array("aaaPhone", "Android", "iPhone", "Common")
thirdLvValFor_01 = Array("Beginner", "Text", "PhoneCall", "mail", "camera",)
thirLvValFor_02 = Array("Security", "SomeSnsApps")
Set rng = Application.Intersect(Target, Me.Range("M31:AM53"))
If Not rng Is Nothing Then 'only loop though any cells in M31:AM53
For Each cell In rng.Cells
If cell.Value = "Session" And cell.Offset(0, -2).Value = "Trial" Then
cell.Offset(0, -2).Resize(1, 3).Interior.Color = trlRed
ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "aaaPhone" And cell.Offset(0, -2).Value <> "TRIAL" Then
cell.Offset(0, -2).Resize(1, 3).Interior.Color = aaaPhoneYellow
ElseIf cell.Value = "aaaPhone" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
cell.Offset(0, -1).Resize(1, 3).Interior.Color = aaaPhoneYellow
Else
cell.Interior.ColorIndex = xlColorIndexNone
End If
Next cell
End If
End Sub
I need help for a macro code.
In my case the excel macro checks data in one sheet ("Check_file") for completeness and correctness.
There are mandatory columns in the sheet which have to exist and also not-mandatory columns can exist.
In my example the columns “company” and “fee” are mandatory columns, if they are missing or false the macro will throw an error.
Next to them, the column “gross fee” is not-mandatory and its data should only be checked with the data in column “fee”, if column “gross fee” exists. If it exists, the amount should be the same as in column “fee”. If it doesnt exist, there should be no comparison.
The check for the mandatory columns works fine within a For-Loop and an own Range.
My problem is that I dont know how I can involve the not-mandatory columns into the loop of the mandatory columns…
I tried to define a separate Range for the not-mandatory columns area. But it seems that I cannnot create the connection to the not-mandatory column if it is not set in the mandatory columns loop. But if it is set to the mandatory columns range and the not-mandatory column doesnt exist, an error will be thrown.
Should the exist-check for the not-mandatory columns be placed in a separate Sub or Function? If yes, how can the connection be created to the mandatory check Range?
This is the vba code:
Function Main_Check(ByVal StrFilePath As String) As String
'//Checks all criteria for the correct filling of the template. Marks all fields that are incorrectly
filled in red.
Dim WB As Workbook, WS As Worksheet
Dim i As Long, iNotMand As Long, lEnde As Long, strHeader As String, ii As Long, lColEnde As Long
Dim rngFind As Range, booCheck As Boolean, rngHeader As Range, rngKey As Range, rngUsed As Range,
rngHeaderNotMand As Range, rngFindNotMand As Range, rngKeyGrossFee As Range, rngGrossFee As Range
Dim strKey As String, arrKey As String, strKeyGrossFee As String, strGrossFee As String
On Error GoTo ErrorHandler
If StrFilePath = “” Then GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'//Template is opened
Set WB = Workbooks.Open(StrFilePath)
Set WS = WB.Worksheets(“Check_file”)
With WS
.Cells.EntireColumn.AutoFit
'//Stores the last row and column to be processed
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
lColEnde = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
'//Find the beginning of the table
Set rngFind = .Cells.Find(what:=Settings.Cells(Settings.Range("Header_Start").Row + 1, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngFind Is Nothing Then
booCheck = False
End
End If
.Range(rngFind.Address, .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row,
rngFind.Column)).EntireRow.Hidden = False
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
'//booCheck is set to true and on error to false _
Thus, if "True" is passed, the complete file is correct
Set rngUsed = .Range(rngFind.Address, .Cells(lEnde, lColEnde))
booCheck = IsErrorAll(rngUsed)
'//Header Check _
Checks all headers in advance to see if they are present and writes the missing ones in a cell
.Cells(4, 7).Clear
.Cells(4, 8).Clear
For i = Settings.Range("Header_Start").Row + 1 To Settings.Range("Header_Ende").Row - 1
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=Settings.Cells(i, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngHeader Is Nothing Then
booCheck = False
.Cells(4, 7).Value = "The following column labels were not found: "
If .Cells(4, 8).Value = "" Then
.Cells(4, 8).Value = .Cells(4, 8).Value & Settings.Cells(i, 2).Value
Else
.Cells(4, 8).Value = "," & .Cells(4, 8).Value & Settings.Cells(i, 2).Value
End If
.Cells(4, 8).Interior.Color = vbRed
Else
End If
Next i
If booCheck = False Then GoTo Ende
'// Check Not-Mandatory Columns _
Checks in advance whether Not-mandatory columns are available
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
For iNotMand = Settings.Range("NotMand_Start").Row + 1 To Settings.Range("NotMand_Ende").Row - 1
Set rngHeaderNotMand = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=Settings.Cells(iNotMand, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not rngHeaderNotMand Is Nothing Then
'//Not-mandatory columns are defined
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Else
strKeyGrossFee = ""
End If
'//All line items are run through and the individual criteria are checked
For i = rngFind.Row + 1 To lEnde Step 1
'//Company
strKey = "Company"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
iCoi = rngHeader.Column
If .Cells(i, rngHeader.Column).Value Like "####" Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
Else
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
End If
'//Fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngHeader.Column).Value Like "*,*" Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
'//Gross fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Set rngGrossFee = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=strGrossFee, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngGrossFee.Column).Value Is Nothing Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
ElseIf .Cells(i, rngHeader.Column).Value <> .Cells(i, rngGrossFee.Column).Value Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
Next i
End With
'//Define results
Ende:
Main_Check = booCheck & “,” & Replace(CStr(rngFind.Address), “$”, “”)
If booCheck = False Then
WS.Cells(7, 7).Value = “Error counter:”
WS.Cells(7, 8).Value = WS.Cells(7, 8).Value + 1
Else
WS.Cells(7, 7).Value = “Check ok”
WS.Cells(7, 8).Value = “”
End If
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Function
'//If there are other errors, it should exit here and return ERROR
ErrorHandler:
On Error GoTo -1
On Error Resume Next
Main_Check = “ERROR”
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Function
I would recommend you refactor your code into 3 parts. 1- read the settings, 2- profile the sheet and then 3- check the data. Debug each step in turn.
Function Main_Check2(ByVal StrFilePath As String) As String
Const CHECK = "Check_file"
Dim wb As Workbook, ws As Worksheet, arHdr
Dim booCheck As Boolean, bExists As Boolean
Dim iColFee As Long, i As Long, msg As String
' check valid filepath
If Dir(StrFilePath) = "" Then
msg = "'" & StrFilePath & "' does not exist"
MsgBox msg, vbCritical, "File not found"
Main_Check2 = msg
Exit Function
End If
' open file and check sheet exists
Set wb = Workbooks.Open(StrFilePath)
bExists = False
For Each ws In wb.Sheets
If ws.Name = CHECK Then
bExists = True
Exit For
End If
Next
If Not bExists Then
msg = "Sheet '" & CHECK & "' not found in " & wb.FullName
MsgBox msg, vbCritical, "Sheet not found"
wb.Close False
Exit Function
End If
' get header details from settings sheet
Call GetSettings(Settings, arHdr)
' check headers, find fee column
booCheck = CheckHeaders(ws, arHdr, iColFee)
'Call DumpArray(arHdr) ' check results so far
' exit if false
If booCheck = False Then
Main_Check2 = booCheck
Exit Function
End If
' check data
With ws
'//All line items are run through and the individual criteria are checked
Dim rngData As Range, sName As String, n As Long
Dim iRow As Long, iCol As Long, lastrow As Long, cell As Range
For i = 1 To UBound(arHdr)
sName = arHdr(i, 1) ' header name
iCol = arHdr(i, 4) ' header column
iRow = arHdr(i, 5) ' header row
n = arHdr(i, 6) ' number of rows
' scan column
If iCol > 0 And n > 0 Then
Set rngData = .Cells(iRow + 1, iCol).Resize(n)
Select Case sName
Case "Company"
For Each cell In rngData
If cell.Value Like "####" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Fee"
For Each cell In rngData
If Not cell.Value Like "*,*" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Gross Fee"
' optional - skipped if icol = 0
For Each cell In rngData
If Len(cell) = 0 Then
cell.Interior.Pattern = xlNone
ElseIf cell.Value <> .Cells(cell.Row, iColFee).Value Then
cell.Interior.Color = vbRed
booCheck = False
Else
cell.Interior.Pattern = xlNone
End If
Next
End Select
End If
Next
End With
'//Define results
Ende:
If booCheck = False Then
ws.Cells(7, 7).Value = "Error counter:"
ws.Cells(7, 8).Value = ws.Cells(7, 8).Value + 1
Else
ws.Cells(7, 7).Value = "Check ok"""
ws.Cells(7, 8).Value = ""
End If
'wb.Close True
Main_Check2 = booCheck '& "," & Replace(CStr(rngFind.Address), "$", "")
End Function
Function GetSettings(ws, ByRef arHdr) As Boolean
Dim r1 As Long, r2 As Long, r3 As Long, r4 As Long
Dim n As Long, m As Long, i As Long, msg As String
With ws
r1 = .Range("Header_Start").Row
r2 = .Range("Header_Ende").Row
r3 = .Range("NotMand_Start").Row
r4 = .Range("NotMand_Ende").Row
m = r2 - r1 - 1 ' mandatory header
n = r4 - r3 - 1 ' non-mandatory headers
If m < 1 Then
msg = "No mandatory headers on setting"
MsgBox msg, vbExclamation, "Settings Error"
getSettings = False
End If
' size array and fill
ReDim arHdr(1 To n + m, 1 To 6)
For i = 1 To m
arHdr(i, 1) = .Cells(r1 + i, 1)
arHdr(i, 2) = .Cells(r1 + i, 2) ' search term
If Len(arHdr(i, 2)) > 0 Then ' skip blanks
arHdr(i, 3) = True ' mandatory
Else
arHdr(i, 3) = False
End If
Next
For i = 1 To n
arHdr(m + i, 1) = .Cells(r3 + i, 1)
arHdr(m + i, 2) = .Cells(r3 + i, 2)
arHdr(m + i, 3) = False ' optional
Next
End With
getSettings = True
End Function
Function CheckHeaders(ws, ByRef arHdr, ByRef iColFee) As Boolean
'//Header Check
'Checks all headers in advance to see if they are present
'and writes the missing ones in a cell
Dim rngTable As Range, rng As Range
Dim msg As String, sHdr As String, sTableStart As String
Dim i As Long, lastrow As Long, rowHdr As Long
Dim booCheck As Boolean
' search value for column 1 of table
sTableStart = arHdr(1, 2)
With ws
'//Find the beginning of the table
Set rngTable = .Cells.Find(what:=sTableStart, LookIn:=xlValues, lookat:=xlWhole)
If rngTable Is Nothing Then
msg = "Could not find begining of table '" & sTableStart & "'"
MsgBox msg, vbExclamation, "Error"
CheckHeaders = False
Exit Function
Else
rowHdr = rngTable.Row
End If
For i = 1 To UBound(arHdr)
sHdr = Trim(arHdr(i, 2))
If Len(sHdr) > 0 Then ' skip blanks
Set rng = .Rows(rowHdr).Find(what:=sHdr, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
arHdr(i, 4) = 0
Else
' store fee column for later gross fee check
If arHdr(i, 1) = "Fee" Then iColFee = rng.Column
arHdr(i, 4) = rng.Column
arHdr(i, 5) = rng.Row
lastrow = .Cells(.Rows.Count, rng.Column).End(xlUp).Row
arHdr(i, 6) = lastrow - rng.Row - 1 ' data rows
End If
Else
arHdr(i, 4) = 0
End If
Next
' check for mandatory column errors
Dim sep As String
For i = 1 To UBound(arHdr)
If arHdr(i, 3) And arHdr(i, 4) = 0 Then
msg = msg & sep & arHdr(i, 2)
sep = ","
End If
Next
If Len(msg) > 0 Then
.Cells(4, 7) = "The following column labels were not found: "
.Cells(4, 8) = msg
.Cells(4, 8).Interior.Color = vbRed
CheckHeaders = False
'GoTo Ende
Else
.Cells(4, 7).Clear ' G4
.Cells(4, 8).Clear ' H4
CheckHeaders = True
End If
End With
End Function
' dump array to new workbook to debug
Sub DumpArray(ar)
Dim wb As Workbook: Set wb = Workbooks.Add
With wb.Sheets(1)
.Name = "arHdr"
.Range("A1:F1") = Array("Header1", "Header2", "Mandatory", "Column", "Row", "DataRows")
.Range("A2").Resize(UBound(ar), UBound(ar, 2)) = ar
End With
' save - replace existing
Application.DisplayAlerts = False
wb.SaveAs "debug_arHdr.xlsx"
Application.DisplayAlerts = True
'wb.Close
End Sub
This is a silly question, but I can't seem to find the issue with the code after a lot of hunting. I'm creating a For Each loop that finds all incidences of "Friday," goes over to the cell 6 columns over from "Friday" (under the "Overtime" heading), inserts the number 0 in that cell, and changes the number format. Here is my worksheet so far.
Here is my code:
Sub Calendar_Generator()
Dim WS As Worksheet
Dim MyInput As String
Dim StartDay As Date
Dim Sp() As String
Dim a As Integer
Dim R As Long
Dim Match As Range
Dim b As Variant
Dim DayNames() As String
Dim FirstAddress As String
Dim DeleteDays As Range
Dim c As Variant
Dim Day1 As Range
Dim WorkDays As Range
Dim d As Variant
'Dim Fri As Range
Set WS = ActiveWorkbook.ActiveSheet
WS.Range("A1:R100").Clear
'This loop is crashing excel
'Do
MyInput = InputBox("Enter the start date for the Calendar:")
'If MyInput = "" Then Exit Sub
'Loop While Not IsDate(MyInput)
' repeat if entry isn't recognized as a date
' Set the date value of the beginning of inputted month.
' -- regardless of the day the user entered, even if missing
StartDay = DateSerial(Year(CDate(MyInput)), Month(CDate(MyInput)), 1)
'Set headers
Range("a1").Value = Format(StartDay, "mmmm") & " Time Sheet"
Sp = Split("Day,Date,Time In,Time Out,Hours,Notes,Overtime", ",")
For a = 0 To UBound(Sp)
WS.Cells(2, 1 + a).Value = Sp(a)
Next a
' fill the days for the selected month
' == the last day of a month is always the day before the first of the next
' here deducting 2 to count from 0
For R = 0 To Day(DateAdd("m", 1, StartDay) - 2)
With WS.Cells(3 + R, 2)
.Value = StartDay + R
.NumberFormat = "d-mmm"
.Offset(, -1).Value = StartDay + R
.Offset(, -1).NumberFormat = "dddd"
End With
Next R
ReDim DayNames(1)
'To add more headers, change statement to 3
DayNames(0) = "Saturday"
DayNames(1) = "Sunday"
For b = LBound(DayNames) To UBound(DayNames)
Set Match = WS.Cells.Find(What:=DayNames(b), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, _
MatchCase:=True, SearchFormat:=False)
If Not Match Is Nothing Then
FirstAddress = Match.Address
Do
Match.EntireRow.Clear
'Highlight cell containing table heading in green
Set Match = WS.Cells.FindNext(Match)
Loop While Not Match Is Nothing
End If
Next b
Set DeleteDays = Range("A3:A50")
For Each c In DeleteDays
If c = "" Then
c.EntireRow.Delete
End If
Next c
'Works for some reason if it's executed twice
Set DeleteDays = Range("A3:A50")
For Each c In DeleteDays
If c = "" Then
c.EntireRow.Delete
End If
Next c
'Insert and format template time values with formula for hours worked in E3
Set Day1 = Range("B3")
Range(Day1, Day1.End(xlDown)).Select
With Selection
Selection.Offset(, 1).Value = "8:00 AM"
Selection.Offset(, 1).NumberFormat = "h:mm AM/PM"
Selection.Offset(, 2).Value = "4:00 PM"
Selection.Offset(, 2).NumberFormat = "h:mm AM/PM"
Selection.Offset(, 3).Value = "0"
Selection.Offset(, 3).NumberFormat = "h:mm"
Day1.Offset(, 3).Formula = "=D3-C3"
End With
'Fill in hours worked formula
Day1.Offset(, 3).Select
Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown))
'*This is the loop that isn't functioning, but also isn't calling any errors*
'Set Overtime calculation
Set WorkDays = Range("A3:A33")
For Each d In WorkDays
If d = "Friday" Then
d.Offset(, 6).Value = "0"
d.Offset(, 6).NumberFormat = "h:mm"
End If
Next d
End Sub
I've had some trouble with loops crashing Excel since I switched to Excel 365, but this For Each loop isn't crashing it. Any ideas as to why this For Each loop isn't doing its job?
I have a excel sheet like at below. I want to find some strings in my excel's third cell. The string is 180 days. When the cell value includes 180 days, I want write previous cells value in next to empty cells like in below picture. I want to write process plan in first cell, operation title in second cell. I wrote this codes but it's not working like what I want.
Sub Button1_Click()
Dim excelRange As Long
Dim i As Long
Dim k As Long
'Dim txt As String
excelRange = ActiveSheet.Cells(1048576, 3).End(xlUp).Row
k = 2
For a = 2 To excelRange
txt = Cells(a, 3)
k = a
If InStr(1, txt, "180 days") > 0 Then
For i = a To 2 Step -1
txt1 = Cells(i, 3)
If InStr(1, txt1, "Oper Title") > 0 Then
Cells(a, 2) = Cells((k + 1), 3)
ElseIf InStr(1, txt1, "Process") > 0 Then
Cells(a, 1) = Cells(k, 3)
Else:
k = k - 1
End If
Next i
End If
Next a
End Sub
Sub test()
Dim excelRange As Range
Dim criteriRange As Range
Dim evaluateRange As Range
Dim c As Range
Dim i As Long
Set excelRange = Range("C1:C" & Cells(1048576, 3).End(xlUp).Row)
For Each cell In excelRange
If UCase(cell.Text) Like "*180 DAY*" Then
If criteriRange Is Nothing Then
Set criteriRange = cell
Else
Set criteriRange = Union(criteriRange, cell)
End If
End If
Next
If Not criteriRange Is Nothing Then
For Each c In criteriRange
For i = c.Row To 1 Step -1
If UCase(Cells(i, 3)) Like "*PROCESS PLAN*" Then
c.Offset(0, -2) = Cells(i, 3)
Exit For
End If
Next
For i = c.Row To 1 Step -1
If UCase(Cells(i, 3)) Like "*OPER TITLE*" Then
c.Offset(0, -1) = Cells(i + 1, 3)
Exit For
End If
Next
Next
End If
End Sub
Instead of looping through a range, your macro will run much faster if you use the Range.Find method.
In your code, you did not check to ensure that all of your sets of Process | Title | 180 Days are complete. I added that to the code below, by making sure that the Process and Title rows were found after the previous 180 day row (or before the 180 day row for the first instance).
In your code, you did not check to see if the cells where you want to output this information are, in fact, empty. If you really want to do that, you can easily modify this code to check these cells before writing to them.
Hopefully, through the comments and the use of meaningful variable names, you will be able to understand what is going on. But you might want to also read through VBA Help for the Range.Find method.
In general, we search down to find the 180 day row, then search up from there to find the associated Process and Title rows.
If a preceding Process or Title row should be before the preceding 180 day row, then we have an incomplete set, output the error message, and terminate the procedure.
If necessary, you could develop procedures to deal with incomplete data sets.
Option Explicit
Sub Info()
Dim searchRng As Range, C As Range, cProcessPlan As Range, cOperTitle As Range
Dim firstAddress As String 'to check when we are done
Dim lastAddress As String 'to check for incomplete data sets
'Where are we looking?
Set searchRng = ThisWorkbook.Worksheets("Sheet1").Columns(3)
With searchRng
Set C = .Find(what:="180 Days", after:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If Not C Is Nothing Then
firstAddress = C.Address
lastAddress = C.Address
Set cOperTitle = .Find(what:="Oper Title", after:=C, searchdirection:=xlPrevious)
Set cProcessPlan = .Find(what:="Process Plan", after:=C, searchdirection:=xlPrevious)
If Not cOperTitle Is Nothing Or Not cProcessPlan Is Nothing Then
'check for full set
If cOperTitle.Row > Range(lastAddress).Row Or cProcessPlan.Row > Range(lastAddress).Row Then
MsgBox "Incomplete Data Set" & vbLf & "Before: " & C.Address
Exit Sub
End If
C.Offset(0, -1) = cOperTitle.Offset(1, 0)
C.Offset(0, -2) = cProcessPlan
Else
MsgBox "Title or Process Plan not found"
Exit Sub
End If
Do
Set C = .Find(what:="180 Days", after:=C, LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If C.Address = firstAddress Then Exit Do
Set cOperTitle = .Find(what:="Oper Title", after:=C, searchdirection:=xlPrevious)
Set cProcessPlan = .Find(what:="Process Plan", after:=C, searchdirection:=xlPrevious)
'check for a full set
If cOperTitle.Row < Range(lastAddress).Row Or cProcessPlan.Row < Range(lastAddress).Row Then
MsgBox "Incomplete Data Set" & vbLf & "Between: " & lastAddress & " and " & C.Address
Exit Sub
End If
C.Offset(0, -1) = cOperTitle.Offset(1, 0)
C.Offset(0, -2) = cProcessPlan
lastAddress = C.Address
Loop
End If
End With
'next stuff
End Sub
Using a variant array is fast.
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim vDB As Variant
Dim vRow(), vTitle(), vProcess()
Dim i As Long, j As Long, k As Long, m As Long
Set Ws = ActiveSheet
With Ws
Set rngDB = .Range("a1", .Range("c" & Rows.Count).End(xlUp))
End With
vDB = rngDB
For i = 1 To UBound(vDB, 1)
If InStr(vDB(i, 3), "180 days") Then
j = j + 1
ReDim Preserve vRow(1 To j)
vRow(j) = i
ElseIf InStr(vDB(i, 3), "Oper Title") Then
k = k + 1
ReDim Preserve vTitle(1 To k)
vTitle(k) = vDB(i + 1, 3)
ElseIf InStr(vDB(i, 3), "Process") Then
m = m + 1
ReDim Preserve vProcess(1 To m)
vProcess(m) = vDB(i, 3)
End If
Next i
For i = 1 To j
vDB(vRow(i), 1) = vProcess(i)
vDB(vRow(i), 2) = vTitle(i)
Next i
rngDB = vDB
End Sub
Option Explicit
Private Sub Worksheet_Activate()
Dim r As Range, rng As Range, snRow As Range, TmRow As Range
Dim x As Integer, ETRow As Long, LTRow As Long
Dim TMName As String
Application.ScreenUpdating = False
ETRow = 10: LTRow = 10
ActiveSheet.Range("C4:AG5,C11:L41").ClearContents
For x = 1 To Sheets.Count
If Sheets(x).Name <> "Summary" Then
With Sheets(Sheets(x).Name)
TMName = Left(Sheets(x).Name, 6)
With .Range("C:C")
Set snRow = .Find("Total Staff (inc Supervisors)", LookIn:=xlValues, LookAt:=xlWhole)
End With
Set rng = .Range("D5", "AH5")
For Each r In rng
If InStr(1, r.Value, "LT") > 0 Then
With Sheets("Summary")
.Cells(5, r.Column - 1) = Sheets(Sheets(x).Name).Cells(snRow.Row, r.Column).Value
With .Range("I9:L9")
Set TmRow = .Find(TMName, LookIn:=xlValues, LookAt:=xlWhole)
End With
.Cells(LTRow, TmRow.Column) = Left(r.Value, InStr(1, r.Value, "LT", vbTextCompare) - 1)
LTRow = LTRow + 1
End With
ElseIf InStr(1, r.Value, "ET") > 0 Then
With Sheets("Summary")
.Cells(4, r.Column - 1) = Sheets(Sheets(x).Name).Cells(snRow.Row, r.Column).Value
With .Range("C9:F9")
Set TmRow = .Find(TMName, LookIn:=xlValues, LookAt:=xlWhole)
End With
.Cells(ETRow, TmRow.Column) = Left(r.Value, InStr(1, r.Value, "ET", vbTextCompare) - 1)
ETRow = ETRow + 1
End With
End If
Next
End With
End If
Next
Application.ScreenUpdating = True
End Sub
It is saying there is an issue with
.Cells(LTRow, TmRow.Column) = Left(r.Value, InStr(1, r.Value, "LT", vbTextCompare) - 1)
and
.Cells(ETRow, TmRow.Column) = Left(r.Value, InStr(1, r.Value, "ET", vbTextCompare) - 1)
This code works on a roster with 4 sheets if the user puts in ET or LT next to the date it then counts if someone is on duty (signified by W)
The code is for summary sheet.
Not sure why as it doesn't work but as soon as I try to change the actual summary sheet by adding an extra row below C5 this happens. Then even if I undo everything, it still occurs.
The problem is that you are assigning value to
.Cells(LTRow, TmRow.Column) and in the line before you have:
Set TmRow = .Find(TMName, LookIn:=xlValues, LookAt:=xlWhole)
Thus, if TmRow is not assigned to a value through the .Find(), TmRow.Column would give this error.
Try to go around like this:
With .Range("I9:L9")
Set TmRow = .Find(TMName, LookIn:=xlValues, LookAt:=xlWhole)
If TmRow Is Nothing Then
MsgBox "TmRow knows nothing"
Stop
End If
End With
Then think of a way to rebuild your code.