Could someone help me find out what is wrong with this VBA Code, please?
In the vba code workbook BASE has more than 3000 items in column A and Each line has a name, for example: "B-Y0011".
I want to search this item in another workbook named in this vba code 'wb'.
BUT this workbook 'wb' has three sheets. I have to find the item in one of these sheets and the line position which the item is on.
It ran one time, but when it doesn't find it, it got an error. And now that I tried to add an ERROR function, it gives me another ERROR.
Thank you so much
Sub ATUALIZAR_ALOCACAO()
Dim caminho As String, Dim j As Variant, Dim plan As Variant, Dim plan1 As
Variant, Dim plan2 As Variant, Dim wb As Workbook, Dim ws As Worksheet
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.EnableEvents = False
mes = InputBox("Qual o mês que você está consolidando informação de Diesel?")
ano = ThisWorkbook.Sheets("BASE").Range("R1").Value
ind_mes = Application.Match(mes, ThisWorkbook.Sheets("BASE").Range("L:L"), 0)
mes_aloc = ThisWorkbook.Sheets("BASE").Range("N" & ind_mes).Value
num_mes = ThisWorkbook.Sheets("BASE").Range("M" & ind_mes).Value
If num_mes < 10 Then
num_mes_cod = "0" & num_mes
Else
num_mes_cod = num_mes
End If
caminho = "\\sedenas01\carnaxide\A&CCC\15 - Brasil - Inovação e
Desenvolvimento\PDCAs\Consumo Diesel\Alocação\2017\" & num_mes_cod &
".RELAÇÃO DE FROTAS GERAL IC " & mes_aloc & " " & ano & ".xls"
Set wb = Workbooks.Open(Filename:=caminho, ReadOnly:=True)
With wb
lastrow = ThisWorkbook.Sheets("BASE").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
j = ThisWorkbook.Sheets("BASE").Cells(i, 1).Value
plan = Application.Match(j, wb.Sheets("BETONEIRAS").Range("K:K"), 0)
On Error Resume Next
If plan > 0 Then
wb.Sheets("BETONEIRAS").Range("M" & plan).Copy
ThisWorkbook.Sheets("BASE").Range("I" & i).PasteSpecial xlPasteValues
wb.Sheets("BETONEIRAS").Range("P" & plan).Copy
ThisWorkbook.Sheets("BASE").Range("J" & i).PasteSpecial xlPasteValues
Else
plan1 = Application.Match(j, wb.Sheets("BOMBAS DE CONCRETO").Range("K:K"), 0)
If plan1 > 0 Then
wb.Sheets("BOMBAS DE CONCRETO").Range("M" & plan1).Copy
ThisWorkbook.Sheets("BASE").Range("I" & i).PasteSpecial xlPasteValues
wb.Sheets("BOMBAS DE CONCRETO").Range("P" & plan1).Copy
ThisWorkbook.Sheets("BASE").Range("J" & i).PasteSpecial xlPasteValues
Else
plan2 = Application.Match(j, wb.Sheets("BOMBAS DE CONCRETO").Range("H:H"), 0)
If plan2 > 0 Then
wb.Sheets("PÁS CARREGADEIRAS").Range("J" & plan2).Copy
ThisWorkbook.Sheets("BASE").Range("I" & i).PasteSpecial xlPasteValues
wb.Sheets("PÁS CARREGADEIRAS").Range("L" & plan2).Copy
ThisWorkbook.Sheets("BASE").Range("J" & i).PasteSpecial xlPasteValues
End If
End If
End If
Next
End With
wb.Close SaveChanges:=False
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Related
Scenario
I have three workbooks
Master
Planner
Phonebook
In my master workbook, i have a value in cell I8 on sheet 1.
Master (Sheet 1)
I8 = 2
On sheet 2 i have the following empty columns:
Master (Sheet 2)
Column A (number) Column B (Supplier) Column C (Contact)
I intend to populate these columns with data from both planner workbook and phonebook workbook.
In my planner, I have a list of numbers in column A and suppliers in Column N.
Numbers Supplier
2 A
2 B
2 C
3 D
4 E
2 F
I am trying to copy all the suppliers from my planner workbook that match the value in cell I8 (in this instance it is 2).
I am pasting the numbers (2) in column A and pasting the supplier names into column B in master workbook.
My code already copies and pastes these values fine.
(I am also copying other values from planner into other columns in master - but for this question, these are not relevant).
So this part of my code works fine.
The problem
Once the suppliers have been pasted into column B in master workbook - I also want to copy the contact name for each supplier from my workbook phonebook.
My phonebook workbook has sheets A-Z and suppliers are listed under these sheets alphabetically.
Phonebook:
Supplier (Column A) Contact Name (Column C)
A Linda
Aa Dave
Aa Terry
AB James
A | B | C | D etc... <----- Sheets
I need to look in each sheet in column A of the phonebook for a supplier name that matches the supplier name in column B (master).
If the supplier name matches then I want to copy the contact name in column C over to master workbook column C.
My result should look like this
Master (Sheet 2)
Column A (number) Column B (Supplier) Column C (Contact)
2 A Linda
2 A Linda
Here's my code:
Option Explicit
Sub CreateAnnounce()
Dim WB As Workbook
Dim WB2 As Workbook
Dim i As Long
Dim i2 As Long
Dim j As Long
Dim LastRow As Long
Dim j2 As Long
Dim LastRow2 As Long
Dim ws As Worksheet
'Open Planner
On Error Resume Next
Set WB = Workbooks("2017 Planner.xlsx")
On Error GoTo 0
If WB Is Nothing Then 'open workbook if not open
Set WB = Workbooks.Open("G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx")
End If
'Open PhoneBook
On Error Resume Next
Set WB2 = Workbooks("Phone Book for Food Specials.xls")
On Error GoTo 0
If WB2 Is Nothing Then 'open workbook if not open
Set WB2 = Workbooks.Open("G:\BUYING\Food Specials\1. General\Phone Book\Phone Book for Food Specials.xls")
End If
' ======= Edit #2 , also for DEBUG ======
With WB.Worksheets(1)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
j = 2
For i = 1 To LastRow
' === For DEBUG ONLY ===
Debug.Print CInt(ThisWorkbook.Worksheets(1).Range("I8").Value)
If CInt(ThisWorkbook.Worksheets(1).Range("I8").Value) = .Range("A" & i).Value Then ' check if Week No equals the value in "A1"
ThisWorkbook.Worksheets(2).Range("A" & j).Value = .Range("A" & i).Value
ThisWorkbook.Worksheets(2).Range("B" & j).Value = .Range("N" & i).Value
ThisWorkbook.Worksheets(2).Range("H" & j).Value = .Range("K" & i).Value
ThisWorkbook.Worksheets(2).Range("I" & j).Value = .Range("L" & i).Value
ThisWorkbook.Worksheets(2).Range("J" & j).Value = .Range("M" & i).Value
ThisWorkbook.Worksheets(2).Range("K" & j).Value = .Range("G" & i).Value
ThisWorkbook.Worksheets(2).Range("L" & j).Value = .Range("O" & i).Value
ThisWorkbook.Worksheets(2).Range("M" & j).Value = .Range("P" & i).Value
ThisWorkbook.Worksheets(2).Range("N" & j).Value = .Range("W" & i).Value
ThisWorkbook.Worksheets(2).Range("O" & j).Value = .Range("Z" & i).Value
'Retrieve Contact Details for supplier
'Worksheet 1
'Retrieve Contact Details for supplier
With WB2.Worksheets(2)
LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
j2 = 2
For i2 = 1 To LastRow2
Dim rngToFill As Range
Set rngToFill = .Range("C2")
Do
Debug.Print ThisWorkbook.Worksheets(2).Range("B" & j2).Value
If ThisWorkbook.Worksheets(2).Range("B" & j2).Value Like .Range("A" & i2).Value Then ' check if Company equals the value in "B1 Phonebook"
ThisWorkbook.Worksheets(2).Range("C2").Value = .Range("C" & i2).Value
Set rngToFill = rngToFill.Offset(1, 0)
End If
Loop
Next i2
End With
'Retrieve Contact Details for supplier - END
End If
Next i
End With
End Sub
For some reason, the code is Copying/pasting just 1 single contact name on the first row into master workbook.
I am also aware that at the moment I am only looking across one sheet.
With WB2.Worksheets(2)
I need this code to obviously look across all sheets for all supplier contact names.
Please can someone show me where I am going wrong and how to get this code to work? Thanks in advance.
EDIT:
I have composed the code suggested by user #BjornBogers
'Retrieve Contact Details for supplier
Dim FoundCellRng As Range
Dim ContactValue As String
Dim SearchStr As String
For i2 = 1 To 26
'Assuming --> ThisWorkbook.Worksheets(2).Range("B1").Value is what you are looking for?
SearchStr = ThisWorkbook.Worksheets(2).Range("B2").Value
Set FoundCellRng = WB2.Worksheets(i2).Range("A2:A200").Find(SearchStr)
If (FoundCellRng Is Nothing) Then
'Didn't find anything
Else
'We found it
ContactValue = WB2.Worksheets(i2).Cells(FoundCellRng.Row, FoundCellRng.Column + 2).Value
ThisWorkbook.Worksheets(2).Range("C" & j).Value = ContactValue
Exit For
End If
Next i2
'Retrieve Contact Details for supplier - END
However, this does the same thing, only one contact name is being entered in the top row but nothing more.
EDIT 2:
With the code #R3uK provided, i seem to be getting the following issues:
Supplier names and other values are not copying across correctly.
The same value seems to repeat itself again and again in column I.
For some reason, this code creates another sheet? What is this sheet for?
The code is incredibly slow and i am having to wait 20 minutes or more.
Is there a way to speed this up?
I haven't tested this but you could try the following:
Dim FoundCellRng As Range
Dim ContactValue As String
Dim SearchStr As String
For i = 1 To 26
'Assuming --> ThisWorkbook.Worksheets(2).Range("B1").Value is what you are looking for?
SearchStr = ThisWorkbook.Worksheets(2).Range("B1").Value
Set FoundCellRng = WB2.Worksheets(i).Range("A1:A100").Find(SearchStr)
If (FoundCellRng Is Nothing) Then
'Didn't find anything
Else
'We found it
ContactValue = WB.Worksheets(i).Cells(FoundCellRng.Row, FoundCellRng.Column + 2).Value
Exit For
End If
Next i
Sub CreateAnnounce()
Dim WbMaster As Workbook
Dim wSMaster1 As Worksheet
Dim wSMaster2 As Worksheet
Dim wSMastTemp As Worksheet
Dim WbPlan As Workbook
Dim wSPlan1 As Worksheet
Dim WbPhone As Workbook
Dim wSPhone As Worksheet
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim rngToFill As Range
Dim rngToChk As Range
Set WbMaster = ThisWorkbook
Set wSMaster1 = WbMaster.Sheets(1)
Set wSMaster2 = WbMaster.Sheets(2)
Set wSMastTemp = WbMaster.Sheets.Add
'''Open Planner
Set WbPlan = GetWB("2017 Planner.xlsx", "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx")
Set wSPlan1 = WbPlan.Sheets(1)
'''Open PhoneBook
Set WbPhone = GetWB("Phone Book for Food Specials.xls", "G:\BUYING\Food Specials\1. General\Phone Book\Phone Book for Food Specials.xls")
With wSPlan1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
j = 2
For i = 1 To LastRow
'''Check if Week No equals the value in "A1"
If CInt(wSMaster1.Range("I8").Value) = .Range("A" & i).Value Then
wSMaster2.Range("A" & j).Value = .Range("A" & i).Value
wSMaster2.Range("B" & j).Value = .Range("N" & i).Value
wSMaster2.Range("H" & j & ":J" & j).Value = .Range("K" & i & ":M" & i).Value
wSMaster2.Range("K" & j).Value = .Range("G" & i).Value
wSMaster2.Range("L" & j & ":M" & j).Value = .Range("O" & i & ":P" & i).Value
wSMaster2.Range("N" & j).Value = .Range("W" & i).Value
wSMaster2.Range("O" & j).Value = .Range("Z" & i).Value
'''Store those infos for next results
wSMastTemp.Cells.Clear
wSMastTemp.Range("A1:O1").Value = wSMaster2.Range("A" & j & ":O" & j).Value
'''Retrieve Contact Details for supplier
Set rngToFill = wSMaster2.Range("C" & j)
For Each wSPhone In WbPhone.Sheets
With wSPhone
'''Define properly the Find method to find all
Set rngToChk = .Columns(1).Find(What:=wSMaster2.Range("B" & j).Value, _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'''If there is a result, keep looking with FindNext method
If Not rngToChk Is Nothing Then
FirstAddress = rngToChk.Address
Do
'''Transfer the cell value to the master
rngToFill.Value = rngToChk.Offset(, 2).Value
'''Go to next row on the template for next Transfer
Set rngToFill = rngToFill.Offset(1, 0)
'''Copy the Info from 1st row for the next result
wSMaster2.Range("A" & rngToFill.Row & ":O" & rngToFill.Row).Value = wSMastTemp.Range("A1:O1").Value
'''Look until you find again the first result in that sheet
Set rngToChk = .Columns(1).FindNext(rngToChk)
Loop While Not rngToChk Is Nothing And rngToChk.Address <> FirstAddress
Else
End If
End With 'wSPhone
Next wSPhone
'''Restart to fill from the next available row
j = rngToFill.Row
'''Clean Data that was there for the next result of this test
wSMaster2.Range("A" & j & ":O" & j).ClearContents
End If
Next i
End With
Application.DisplayAlerts = False
wSMastTemp.Delete
Application.DisplayAlerts = True
End Sub
Public Function GetWB(FileName As String, FileFullPath As String) As Workbook
On Error Resume Next
Set GetWB = Workbooks(FileName)
On Error GoTo 0
If GetWB Is Nothing Then 'open workbook if not open
Set GetWB = Workbooks.Open(FilePath)
DoEvents
End If
End Function
I have a code that he selected data that I want ,but I want to show this data in a table and not ina MsgBox.
This is my code and I hope that someone can find a solution for me
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim table1 As Range
Dim table2 As Range
Dim table1Rows As Integer
Dim table1Cols As Integer
Set ws1 = Worksheets("Feuil1")
Set ws2 = Worksheets("Feuil2")
Set table1 = ws1.Cells
Set table2 = ws2.Cells
table1Rows = ws1.UsedRange.Rows.Count
table1Cols = ws1.UsedRange.Columns.Count
For i = 1 To table1Rows
For j = 1 To table1Cols
If table1(i, 1).Value <> table2(i, 1).Value Then
MsgBox "Libellé : " & table1(i, 1) & ", du montant : " & table1(i, 3) & " est ajouté !"
End If
Next
Next
End Sub
What you need is ListBox. Create UserForm (e.g. Userform1) and listbox inside of it (e.g. Listbox1). Then you can put the data inside by this formula .AddItem function. Your loop will look like:
For i = 1 To table1Rows
For j = 1 To table1Cols
If table1(i, 1).Value <> table2(i, 1).Value Then
UserForm1.ListBox1.AddItem "Libellé : " & table1(i, 1) & ", du montant : " & table1(i, 3) & " est ajouté !"
End If
Next
Next
End Sub
UserForm1.Show
The project: It deals with very sensitive HR/performance data, and I need to send 1000s of employees' data to their individual managers (about 100 managers who can only see their team's data, and no one else's), so I need about 100 files split (1 for each manager).
The file: - Many different tabs, separated by role. - First column is a unique identifier made by concatenating the Manager's name with the job title ex. John Stevens_Office Manager
The task: John Stevens will have team members in many different job roles, and needs all that data in one file, separated into tabs by job role.
Based on that sample data, the ideal macro would give me 3 files with 3 worksheets in each, and 1 row of data in each worksheet. However, I will settle for the worksheet being split into multiple files.
Here is my code.
Sub SplitWB()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.Save
Dim OutputFolderName As String
OutputFolderName = ""
Set myDlg = Application.FileDialog(msoFileDialogFolderPicker)
myDlg.AllowMultiSelect = False
myDlg.Title = "Select Output Folder for Touchstone Files:"
If myDlg.Show = -1 Then OutputFolderName = myDlg.SelectedItems(1) & "\" Else Exit Sub
Set myDlg = Nothing
Application.CutCopyMode = False
'''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Dim d As Object, c As Range, k, tmp As String, unique(500)
i = 0
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set d = CreateObject("scripting.dictionary")
For Each c In Range(Cells(1, 1), Cells(lastRow, 1))
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
Debug.Print k, d(k)
i = i + 1
unique(i) = k
Next k
UniqueCount = i
'start deleting
For i = 1 To UniqueCount
'Actions for new workbook
wpath = Application.ActiveWorkbook.FullName
wbook = ActiveWorkbook.Name
wsheet = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:=OutputFolderName & unique(i), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
For j = 1 To lastRow
If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then
Rows(j).Delete
j = j - 1
End If
Next
'hide helper columns
' If HideC = False And DeleteC = True Then
Columns("A:D").Hidden = True
' End If
'
Range("E8").Select
'Select Instructions tab
'Worksheets("Guidelines").Activate
'Save new workbook
ActiveWorkbook.Close SaveChanges:=True
Workbooks.Open (wpath)
'ActiveWorkbook.Close False
Workbooks(wbook).Activate
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Macro has completed successfully!" & vbNewLine & vbNewLine & "Generated files can be found in the following directory:" & vbNewLine & OutputFolderName)
End Sub
The code hangs at "If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then"
It is located about half-way into the code and the chunk starts with "For j = 1 To lastRow"
Please help. It will literally save me a day's work or more. Thanks!!!
Try
For j = lastRow to 1 step -1
If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then
Rows(j).Delete
End If
Next
instead. This allows you to loop backwards so when you delete a row it won't lose track of where you want j to be in the loop.
INITIAL QUESTION
Why am I not able to open all (all three) matching workbooks?
Dropdown selection:
1A:1C = Company1 Company2 Company3
2A:2C = Version2 Version1 Version1
Only the first one (Company1, Version2) will open...
Sub OpenWorkbooks()
Dim ColumnIndex1 As Integer
Dim ColumnIndex2 As Integer
Dim ColumnIndex3 As Integer
Dim ColumnIndex4 As Integer
Dim ColumnIndex5 As Integer
Dim ColumnIndex6 As Integer
For ColumnIndex1 = 1 To 3
If Cells(1, ColumnIndex1).Value = "Company1" And Cells(2,
ColumnIndex1).Value = "Version1" Then
Workbooks.Open Filename:="D:\Company1\Version1.xlsx"
End If
Next ColumnIndex1
For ColumnIndex2 = 1 To 3
If Cells(1, ColumnIndex2).Value = "Company1" And Cells(2,
ColumnIndex2).Value = "Version2" Then
Workbooks.Open Filename:="D:\Company1\Version2.xlsx"
End If
Next ColumnIndex2
For ColumnIndex3 = 1 To 3
If Cells(1, ColumnIndex3).Value = "Company2" And Cells(2,
ColumnIndex3).Value = "Version1" Then
Workbooks.Open Filename:="D:\Company2\Version1.xlsx"
End If
Next ColumnIndex3
For ColumnIndex4 = 1 To 3
If Cells(1, ColumnIndex4).Value = "Company2" And Cells(2,
ColumnIndex4).Value = "Version2" Then
Workbooks.Open Filename:="D:\Company2\Version2.xlsx"
End If
Next ColumnIndex4
For ColumnIndex5 = 1 To 3
If Cells(1, ColumnIndex5).Value = "Company3" And Cells(2,
ColumnIndex5).Value = "Version1" Then
Workbooks.Open Filename:="D:\Company3\Version1.xlsx"
End If
Next ColumnIndex5
For ColumnIndex6 = 1 To 3
If Cells(1, ColumnIndex6).Value = "Company3" And Cells(2,
ColumnIndex6).Value = "Version2" Then
Workbooks.Open Filename:="D:\Company3\Version2.xlsx"
End If
Next ColumnIndex6
End Sub
I have just started using VBA (and StackOverflow).
Thank you.
FOLLOW-UP
# Dirk Reichel:
# All:
I have tried to expand Dirk's idea a bit (See below), and I'm trying to open 5 (or less) workbooks in sequence each time copying/pasting a specific range to the 'main2' sheet of the 'main' workbook.
It works fine unless I open fewer workbooks than the number of dropdown values that are being checked (I'm currently using 5 dropdown sets instead of the original 3: see top of page):
Sub ImportData()
Dim MainWorkbook As Workbook
Dim DataWorkbook As Workbook
Dim i As Long
Set MainWorkbook = ThisWorkbook
With MainWorkbook.ActiveSheet
For i = 2 To 6
If ActiveSheet.Cells(6, i).Value <> "" Then
Set DataWorkbook = Workbooks.Open("D:\ 'some folders' \" & .Cells(6,
i).Value & "-" & .Cells(10, 2) & "-" & .Cells(7, i).Value & ".xlsx")
DataWorkbook.Sheets("Sheet1").Range("C3:Q3").Copy
MainWorkbook.Sheets("Main2").Range("A" & i).PasteSpecial
On Error Resume Next
End If
Next i
End With
End Sub
I have used 3 of the (now) 5 dropdown menus, and only 1 workbook is currently being opened and copied...
You may try an easier script like this:
Sub OpenWorkbooks()
Dim i As Long
With ThisWorkbook.ActiveSheet
For i = 1 To 3
Workbooks.Open Filename:="D:\" & .Cells(1, i).Value & "\" & .Cells(2, i).Value & ".xlsx"
Next i
End With
End Sub
if your Cells do not have any "Workbook" and "Worksheet" they will do it with the active one (after opening the first workbook, all your Cells will refer to it and not to the orginal source)
I have a multiple excel in a folder which has Yellow and red color filled in some cells
I need a excel log which will generate the file name count of yellow filed in each excel corresponding to that
eg:
Filename Yellow Red
1.xlsx 13 14
2.xlsx 5 10
can anyone help me.
This will log your Red and Yellow cells in a Sheet called "Log Sheet" in the workbook from which you run this code. Add/name this sheet and any formatting you require yourself. Getting the cell colour of conditionally formatted cells is tricky but you may find help in this article. I have included a column in the Log Sheet to identify IF there are conditionally formatted cells in the worksheet but with no analysis or counts. I have also included a column with the worksheet tab name.
This code analyses the cell colours within the sheets' UsedRange. You will need to enter the path of your data files in the variable dataFileFolder.
Sub countYellowRedCells()
Dim wbk As Variant
Dim wsLog As Worksheet, sht As Worksheet
Dim cCell As Range
Dim cfFlag As Boolean
Dim dataFileFolder As String
Dim redCount As Long, yellowCount As Long
Dim logRowEnd As Long, logCol As Long
Set wsLog = ThisWorkbook.Sheets("Log Sheet")
logCol = 2
redCount = 0
yellowCount = 0
cfFlag = False
dataFileFolder = "C:\......TestFiles\" 'ENTER YOUR PATH
Application.ScreenUpdating = False
wbk = Dir(dataFileFolder)
Do Until wbk = ""
Workbooks.Open dataFileFolder & wbk
For Each sht In ActiveWorkbook.Worksheets
For Each cCell In sht.UsedRange
If cCell.FormatConditions.count <> 0 Then cfFlag = True
Select Case cCell.Interior.Color
Case Is = RGB(255, 0, 0)
redCount = redCount + 1
Case RGB(255, 255, 0)
yellowCount = yellowCount + 1
End Select
Next cCell
With wsLog
logRowEnd = .Cells(Rows.count, logCol).End(xlUp).Row
.Cells(logRowEnd, logCol).Offset(1, 0).Value = ActiveWorkbook.Name
.Cells(logRowEnd, logCol).Offset(1, 1).Value = sht.Name
.Cells(logRowEnd, logCol).Offset(1, 2).Value = yellowCount
.Cells(logRowEnd, logCol).Offset(1, 3).Value = redCount
.Cells(logRowEnd, logCol).Offset(1, 4).Value = cfFlag
End With
'MsgBox (ActiveWorkbook.Name & " - Sheet: " & sht.Name & Chr(10) _
& redCount & " Red cells." & Chr(10) & yellowCount & " Yellow cells.")
redCount = 0
yellowCount = 0
cfFlag = False
Next sht
Workbooks(wbk).Close savechanges:=False
wbk = Dir
Loop
Application.ScreenUpdating = True
End Sub