Extracting data from worksheets based on cell value criteria

[Thebatfink]

Hi,

I have a piece of code which is opening workbooks and drawing cell values from various sheets in each of these workbooks and closing them back down as it goes along.

I require it now to do something further with the workbooks whilst they are open. I want it to scan down a fixed range "a7:a40" within worksheets MONDAY, TUESDAY, WEDNESDAY, THURSDAY, FRIDAY, SATURDAY, SUNDAY (sheetnames) of each of the workbooks it opens and look for values (the values will be either blank or one of three fixed values). What I want is if it finds the phrase "Phrase 1" then take the number from that row reference from column y (always a number value), remember it, and add it to the next instance of "Phrase 1" and so on. This is in addition to what its already doing. It runs quite quickly so this could be a completely seperate sub that runs after my initial code??

I already have some code that does a very similar thing, but it was designed by someone on the board and it was and still is beyond my scope of coding. So I am looking for some assistance with it. This code does the same kind of thing that I want but only within the same workbook and only looking at 1 sheet (I need it to scan 7 sheets of each workbook and do 1 lot of totals for all 7 worksheets together.

The resulting data I would like putting into Sheet1 as follows
File1 Phrase1 value to "m7", Phrase2 value to "n7", Phrase3 value to "o7"
File2 Phrase1 value to "m8", Phrase2 value to "n8", Phrase3 value to "o8"
etc etc

My original code which I would like this to be integrated too:

Private Sub update2_Click()
Dim myDir As String, fn As String, ws As Worksheet, MCCode1complete As String, MCCode2complete As String, MCCode3complete _
As String
myDir = "\\server\folder\folder\"
fn = Dir(myDir & "*MCCode1*.xls")
If fn = "" Then
MsgBox "The folder does not contain any MCCode1 files or the folder does not exist." & vbNewLine & vbNewLine & _
"If this problem persists contact NAME (EMAIL ADDY)", 48, "Unable To Update": GoTo MCCode1minerfail:
End If
If MsgBox("Updating may take several minutes to complete (Excel will be unresponsive during this time)." _
& vbNewLine & vbNewLine & "Do you still want to update?", vbYesNo + vbQuestion, "Confirm Update") = vbNo Then Exit Sub
Sheet1.Unprotect Password:="password"
Sheet1.Range("a7:i100").ClearContents
Application.ScreenUpdating = False
Do While fn <> ""
On Error GoTo MCCode1openfail:
    Application.EnableEvents = False
    Workbooks.Open myDir & fn
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name = "MONDAY" Then
            Set ws = sh
        ElseIf sh.Name = "ANALYSIS" Then
            Set ws2 = sh
        End If
    Next sh
    Sheet1.Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = _
        Array(ws.Range("i1").Value, ws2.Range("b5").Value, myDir & fn, fn & "-" & ws.Name)
    Workbooks(fn).Close False
    Application.EnableEvents = True
    fn = Dir
Loop
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 7 To lastrow
    link = Cells(i, 3).Value
    Sheet4.Hyperlinks.Add Anchor:=Cells(i, 3), Address:=link, TextToDisplay:="Click To View File"
Next i
MCCode1complete = "Yes"
GoTo MCCode2miner:
MCCode1openfail:
MsgBox "Error accessing files. Please ensure all files are closed before updating." & vbNewLine & vbNewLine & _
"If this problem persists contact NAME (EMAIL ADDY)"
MCCode1complete = "No"
GoTo MCCode2miner:
MCCode1minerfail:
MCCode1complete = "No"
MCCode2miner:
fn = Dir(myDir & "*MCCode2*.xls")
If fn = "" Then
MsgBox "The folder does not contain any MCCode2 files or the folder does not exist." & vbNewLine & vbNewLine & _
"If this problem persists contact NAME (EMAIL ADDY)", 48, "Unable To Update": GoTo MCCode2minerfail:
End If
Application.ScreenUpdating = False
Do While fn <> ""
On Error GoTo MCCode2openfail:
    Application.EnableEvents = False
    Workbooks.Open myDir & fn
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name = "MONDAY" Then
            Set ws = sh
        ElseIf sh.Name = "ANALYSIS" Then
            Set ws2 = sh
        End If
    Next sh
    Sheet1.Range("d" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = _
        Array(ws.Range("i1").Value, ws2.Range("b5").Value, myDir & fn, fn & "-" & ws.Name)
    Workbooks(fn).Close False
    Application.EnableEvents = True
    fn = Dir
Loop
lastrow = Cells(Rows.Count, 6).End(xlUp).Row
For i = 7 To lastrow
    link = Cells(i, 6).Value
    Sheet1.Hyperlinks.Add Anchor:=Cells(i, 6), Address:=link, TextToDisplay:="Click To View File"
Next i
MCCode2complete = "Yes"
GoTo MCCode3miner:
MCCode2openfail:
MsgBox "Error accessing files. Please ensure all files are closed before updating." & vbNewLine & vbNewLine & _
"If this problem persists contact NAME (EMAIL ADDY)"
MCCode2complete = "No"
GoTo MCCode3miner:
MCCode2minerfail:
MCCode2complete = "No"
MCCode3miner:
fn = Dir(myDir & "*MCCode3*.xls")
If fn = "" Then
MsgBox "The folder does not contain any MCCode3 files or the folder does not exist." & vbNewLine & vbNewLine & _
"If this problem persists contact NAME (EMAIL ADDY)", 48, "Unable To Update": GoTo MCCode3minerfail:
End If
Application.ScreenUpdating = False
Do While fn <> ""
On Error GoTo MCCode3openfail:
    Application.EnableEvents = False
    Workbooks.Open myDir & fn
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name = "MONDAY" Then
            Set ws = sh
        ElseIf sh.Name = "ANALYSIS" Then
            Set ws2 = sh
        End If
    Next sh
    Sheet1.Range("g" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = _
        Array(ws.Range("i1").Value, ws2.Range("b5").Value, myDir & fn, fn & "-" & ws.Name)
    Workbooks(fn).Close False
    Application.EnableEvents = True
    fn = Dir
Loop
lastrow = Cells(Rows.Count, 9).End(xlUp).Row
For i = 7 To lastrow
    link = Cells(i, 9).Value
    Sheet1.Hyperlinks.Add Anchor:=Cells(i, 9), Address:=link, TextToDisplay:="Click To View File"
Next i
MCCode3complete = "Yes"
GoTo MCCodesort:
MCCode3openfail:
MsgBox "Error accessing files. Please ensure all files are closed before updating." & vbNewLine & vbNewLine & _
"If this problem persists contact NAME (EMAIL ADDY)"
MCCode3complete = "No"
GoTo MCCodesort:
MCCode3minerfail:
MCCode3complete = "No"
MCCodesort:
Sheet1.Range("g3").Value = Now
Sheet1.Range("h3").Value = Environ("Username")
Sheet1.Range("a7:c100").Select
        Selection.Sort Key1:=Range("a7"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Sheet1.Range("d7:f100").Select
        Selection.Sort Key1:=Range("d7"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Sheet1.Range("g7:i100").Select
        Selection.Sort Key1:=Range("g7"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Sheet1.Protect Password:="password"
ActiveWorkbook.Save
Range("h3").Select
Application.ScreenUpdating = True
MsgBox "MCCode1 Update Completed Sucessfully -   " & hm1complete & "   " & vbNewLine & _
"MCCode2 Update Completed Successfully  -   " & hm2complete & "   " & vbNewLine & _
"MCCode3 Update Completed Successfully -   " & hm3complete & "   " & vbNewLine & vbNewLine & _
"Update complete", vbQuestion, "Update Status"
Exit Sub
End Sub

Here is the code which I've salvaged out of an existing workbook I would like to integrate somehow and change to do the above.

        Dim a, i As Long, b(), n As Long
With Sheets("OEE")
    a = .Range("v20", .Range("v" & Rows.Count).End(xlUp)).Offset(, -1).Resize(, 2).Value
End With
ReDim b(1 To UBound(a, 1), 1 To 4)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
       If Not IsEmpty(a(i, 2)) Then
        If Not .Exists(a(i, 2)) Then
             n = n + 1: b(n, 1) = a(i, 2): .Add a(i, 2), n
       End If
            b(.Item(a(i, 2)), 2) = b(.Item(a(i, 2)), 2) + 1
            If a(i, 1) <> "" Then
               b(.Item(a(i, 2)), 3) = b(.Item(a(i, 2)), 3) + 1
                b(.Item(a(i, 2)), 4) = b(.Item(a(i, 2)), 4) + a(i, 1)
            End If
        End If
    Next
End With
Worksheets("Reports").Range("o4:v505").ClearContents
With Sheets("Reports").Range("o4")
    .Cells.Font.Name = "Arial"
    .Resize(, 4).Value = [{"problem","Total occurence","occurence with min","Total min"}]
    .Offset(1).Resize(n, 4).Value = b
End With
   Worksheets("Reports").Range("o5:r505").Sort _
        Key1:=Worksheets("Reports").Columns("r"), _
        Header:=xlGuess
Dim c, j As Long, d(), k As Long
With Sheets("OEE")
    c = .Range("p20", .Range("p" & Rows.Count).End(xlUp)).Offset(, -1).Resize(, 2).Value
End With
ReDim d(1 To UBound(c, 1), 1 To 4)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For j = 1 To UBound(c, 1)
       If Not IsEmpty(c(j, 2)) Then
        If Not .Exists(c(j, 2)) Then
             k = k + 1: d(k, 1) = c(j, 2): .Add c(j, 2), k
       End If
            d(.Item(c(j, 2)), 2) = d(.Item(c(j, 2)), 2) + 1
            If c(j, 1) <> "" Then
               d(.Item(c(j, 2)), 3) = d(.Item(c(j, 2)), 3) + 1
                d(.Item(c(j, 2)), 4) = d(.Item(c(j, 2)), 4) + c(j, 1)
            End If
        End If
    Next
End With
With Sheets("Reports").Range("s4")
    .Resize(, 4).Value = [{"problem","Total occurence","occurence with min","Total min"}]
    .Offset(1).Resize(k, 4).Value = d
End With

My instinct tells me this is quite a complicated task and I know its beyond me, but if anyone could spare sometime to have a look at it I would really appreciated it. If I havent explained things very well, please let me know and I'll do my best to explain.

Thanks for any help!
Batfink

 

[ColinKJ]

Hi Thebatfink,

If I send you a private message with my email address would you be able to send me one on the sample workbooks you open

ColinKJ