gustavejones
New Member
- Joined
- Feb 2, 2014
- Messages
- 1
I am getting a problem with a VBA for excel. I use this macro to go into other stored excel workbooks, scan all the worksheets for dates on when a certain class starts a certain area. Then it will compile all the infromation into one worksheet and sort by starting date. After I expanded the items it was looking for, I hit the size limit and had to break it into two subs. Now the promblem is that the first sub runs fine but when the second one runs it overwrite the data in the first sub. I tried to insert the following with errors.
iRow = Ws.Cells(Ws.Rows.Count, 1) _
.End(xlUp).Row + 1
Here is a reduced version of the macro since it pushes 3000 lines completely. I am sure there is a simply way to do this, but I took this over from someone else. Any help or ideas would be great.
Thank you
Option Explicit
Function fncIs15G(ByRef Class As String) As Boolean
Select Case Class
' 151A
Case "075-340-14", "9CD-534-03"
fncIs15G = True
' 15K
Case "380-130-13", "9Y7-513-02"
fncIs15G = True
' 15G30
Case "314-300-45", "314-302-40", "314-303-05", "314-309-14", "9W4-505-03"
fncIs15G = True
' 15T30
Case "355-010-16", "355-011-04", "355-013-04", "355-018-04", "9L8-524-03"
fncIs15G = True
' 15U30
Case "356-010-16", "356-011-04", "356-013-04", "355-018-04", "9P4-524-03"
fncIs15G = True
' 15S30
Case "354-010-16", "354-011-04", "354-013-04", "354-018-04", "9S5-524-03"
fncIs15G = True
'15R30
Case "353-010-16", "353-011-04", "354-013-04", "354-018-04", "9N6-524-03"
fncIs15G = True
End Select
End Function
Function fncIs15H(ByRef Class As String) As Boolean
Select Case Class
' 151A
Case "075-750-07", "9CD-535-02"
fncIs15H = True
' 15K
Case "380-140-14", "9Y7-514-01"
fncIs15H = True
' 15H30
Case "350-400-26", "350-375-13", "350-401-28", "9W5-505-02", "9W5-506-02"
fncIs15H = True
' 15T30
Case "355-015-09", "9L8-525-02"
fncIs15H = True
'15U30
Case "356-015-09", "9P4-525-02"
fncIs15H = True
'15S30
Case "354-015-09", "9S5-525-02"
fncIs15H = True
'15R30
Case "353-015-09", "9N6-525-02"
fncIs15H = True
End Select
End Function
Sub Board_Update()
On Error GoTo Error_Handler
Dim intCounterRowSchedule As Integer
Dim intCounterColumn As Integer
Dim curCellNew As Object
Dim curCellOld As Object
Dim intMainCounter As Integer
Dim strDate As String
Dim intMonthDays As Integer
Dim intMonthDaysCounter As Integer
Dim curCellDate As Object
Dim intCounterDate As Integer
Dim appExcel As Application
Dim sheetcount As Integer
Dim strName As String
Dim i As Integer, x As Integer, y As Integer, z As Integer
Dim arySheets() As String
Dim strLastCell As String
Dim dteDate As Date
Dim intcounter As Integer
Dim strFirstDay As String
Dim aryBook() As String
Dim intRow As Integer, intColumn As Integer, intSheet As Integer
Dim arySmall()
Dim aryBig()
Dim strAddress As String
Dim aryFinal(1 To 100, 1 To 256)
Dim intMaxRows As Integer
Dim booNewClass As Boolean
Dim strClass As String
Dim strClassList As String
Dim strClassDateList As String
Dim strClassHourList As String
Dim strClassStopList As String
Dim intMainCounterTop As Integer
Worksheets("Board").Range("A:E") = ""
Worksheets("Board").Cells(1, 1) = "Class"
Worksheets("Board").Cells(1, 2) = "Section"
Worksheets("Board").Cells(1, 3) = "Start"
Worksheets("Board").Cells(1, 4) = "Hour"
Worksheets("Board").Cells(1, 5) = "Stop"
intMainCounter = 1
intcounter = 4
booNewClass = True
strFirstDay = Format(Date, "M") & "/1/" & Format(Date, "YYYY")
' Build the array and fill it with all of the info from the workbook, this should
' greatly increase speed of the update.... i hope
Airframe
Hyd
Worksheets("Board").Range("A:E").Name = "Yeah"
Worksheets("Board").Range("Yeah").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=True
MsgBox "Baby steps", , "SFC Jones Rocks!!!"
Exit_My_Sub:
Exit Sub
Error_Handler:
MsgBox Err.Description, vbOKOnly, "Error Number " & Err.Number
Debug.Print Err.Description
GoTo Exit_My_Sub
End Sub
'******************
'Now starts the Airframe Breakdown
'******************
Sub Airframe()
Dim intCounterRowSchedule As Integer
Dim intCounterColumn As Integer
Dim curCellNew As Object
Dim curCellOld As Object
Dim intMainCounter As Integer
Dim strDate As String
Dim intMonthDays As Integer
Dim intMonthDaysCounter As Integer
Dim curCellDate As Object
Dim intCounterDate As Integer
Dim appExcel As Application
Dim sheetcount As Integer
Dim strName As String
Dim i As Integer, x As Integer, y As Integer, z As Integer
Dim arySheets() As String
Dim strLastCell As String
Dim dteDate As Date
Dim intcounter As Integer
Dim strFirstDay As String
Dim aryBook() As String
Dim intRow As Integer, intColumn As Integer, intSheet As Integer
Dim arySmall()
Dim aryBig()
Dim strAddress As String
Dim aryFinal(1 To 100, 1 To 256)
Dim intMaxRows As Integer
Dim booNewClass As Boolean
Dim strClass As String
Dim strClassList As String
Dim strClassDateList As String
Dim strClassHourList As String
Dim strClassStopList As String
Dim intMainCounterTop As Integer
Worksheets("Board").Range("A:E") = ""
Worksheets("Board").Cells(1, 1) = "Class"
Worksheets("Board").Cells(1, 2) = "Section"
Worksheets("Board").Cells(1, 3) = "Start"
Worksheets("Board").Cells(1, 4) = "Hour"
Worksheets("Board").Cells(1, 5) = "Stop"
intMainCounter = 1
intcounter = 4
booNewClass = True
strFirstDay = Format(Date, "M") & "/1/" & Format(Date, "YYYY")
' Build the array and fill it with all of the info from the workbook, this should
' greatly increase speed of the update.... i hope
'*******************'
' 15U '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_U_Class
End If
End If
Next i
Next x
Found_First_U_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15G(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15G(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_U_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) '- 1
For i = 2 To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 " & strClassList
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
intMainCounter = i + 1
'*******************'
' 15U3 RC '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3 RC.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_URC_Class
End If
End If
Next i
Next x
Found_First_URC_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15G(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15G(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_URC_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3 RC.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) - 1
For i = intMainCounter To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 RC " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 RC " & strClassList
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
End Sub
'******************
'Now starts the Hyd Breakdown
'******************
Sub Hyd()
Dim intCounterRowSchedule As Integer
Dim intCounterColumn As Integer
Dim curCellNew As Object
Dim curCellOld As Object
Dim intMainCounter As Integer
Dim strDate As String
Dim intMonthDays As Integer
Dim intMonthDaysCounter As Integer
Dim curCellDate As Object
Dim intCounterDate As Integer
Dim appExcel As Application
Dim sheetcount As Integer
Dim strName As String
Dim i As Integer, x As Integer, y As Integer, z As Integer
Dim arySheets() As String
Dim strLastCell As String
Dim dteDate As Date
Dim intcounter As Integer
Dim strFirstDay As String
Dim aryBook() As String
Dim intRow As Integer, intColumn As Integer, intSheet As Integer
Dim arySmall()
Dim aryBig()
Dim strAddress As String
Dim aryFinal(1 To 100, 1 To 256)
Dim intMaxRows As Integer
Dim booNewClass As Boolean
Dim strClass As String
Dim strClassList As String
Dim strClassDateList As String
Dim strClassHourList As String
Dim strClassStopList As String
Dim intMainCounterTop As Integer
Dim iRow As Integer
Dim Ws As Object
strFirstDay = Format(Date, "M") & "/1/" & Format(Date, "YYYY")
' Build the array and fill it with all of the info from the workbook, this should
' greatly increase speed of the update.... i hope
'find first empty row in database
iRow = Ws.Cells(Ws.Rows.Count, 1) _
.End(xlUp).Row + 1
'*******************'
' 15U HYD '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_UHYD_Class
End If
End If
Next i
Next x
Found_First_UHYD_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15H(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15H(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_UHYD_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) '- 1
For i = 2 To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 " & strClassList
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
intMainCounter = i + 1
'*******************'
' 15U3 RC HYD '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3 RC.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_URCHYD_Class
End If
End If
Next i
Next x
Found_First_URCHYD_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15H(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15H(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_URCHYD_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3 RC.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) - 1
For i = intMainCounter To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 RC " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 RC " & strClassList
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
End Sub
'********************
'********************
iRow = Ws.Cells(Ws.Rows.Count, 1) _
.End(xlUp).Row + 1
Here is a reduced version of the macro since it pushes 3000 lines completely. I am sure there is a simply way to do this, but I took this over from someone else. Any help or ideas would be great.
Thank you
Option Explicit
Function fncIs15G(ByRef Class As String) As Boolean
Select Case Class
' 151A
Case "075-340-14", "9CD-534-03"
fncIs15G = True
' 15K
Case "380-130-13", "9Y7-513-02"
fncIs15G = True
' 15G30
Case "314-300-45", "314-302-40", "314-303-05", "314-309-14", "9W4-505-03"
fncIs15G = True
' 15T30
Case "355-010-16", "355-011-04", "355-013-04", "355-018-04", "9L8-524-03"
fncIs15G = True
' 15U30
Case "356-010-16", "356-011-04", "356-013-04", "355-018-04", "9P4-524-03"
fncIs15G = True
' 15S30
Case "354-010-16", "354-011-04", "354-013-04", "354-018-04", "9S5-524-03"
fncIs15G = True
'15R30
Case "353-010-16", "353-011-04", "354-013-04", "354-018-04", "9N6-524-03"
fncIs15G = True
End Select
End Function
Function fncIs15H(ByRef Class As String) As Boolean
Select Case Class
' 151A
Case "075-750-07", "9CD-535-02"
fncIs15H = True
' 15K
Case "380-140-14", "9Y7-514-01"
fncIs15H = True
' 15H30
Case "350-400-26", "350-375-13", "350-401-28", "9W5-505-02", "9W5-506-02"
fncIs15H = True
' 15T30
Case "355-015-09", "9L8-525-02"
fncIs15H = True
'15U30
Case "356-015-09", "9P4-525-02"
fncIs15H = True
'15S30
Case "354-015-09", "9S5-525-02"
fncIs15H = True
'15R30
Case "353-015-09", "9N6-525-02"
fncIs15H = True
End Select
End Function
Sub Board_Update()
On Error GoTo Error_Handler
Dim intCounterRowSchedule As Integer
Dim intCounterColumn As Integer
Dim curCellNew As Object
Dim curCellOld As Object
Dim intMainCounter As Integer
Dim strDate As String
Dim intMonthDays As Integer
Dim intMonthDaysCounter As Integer
Dim curCellDate As Object
Dim intCounterDate As Integer
Dim appExcel As Application
Dim sheetcount As Integer
Dim strName As String
Dim i As Integer, x As Integer, y As Integer, z As Integer
Dim arySheets() As String
Dim strLastCell As String
Dim dteDate As Date
Dim intcounter As Integer
Dim strFirstDay As String
Dim aryBook() As String
Dim intRow As Integer, intColumn As Integer, intSheet As Integer
Dim arySmall()
Dim aryBig()
Dim strAddress As String
Dim aryFinal(1 To 100, 1 To 256)
Dim intMaxRows As Integer
Dim booNewClass As Boolean
Dim strClass As String
Dim strClassList As String
Dim strClassDateList As String
Dim strClassHourList As String
Dim strClassStopList As String
Dim intMainCounterTop As Integer
Worksheets("Board").Range("A:E") = ""
Worksheets("Board").Cells(1, 1) = "Class"
Worksheets("Board").Cells(1, 2) = "Section"
Worksheets("Board").Cells(1, 3) = "Start"
Worksheets("Board").Cells(1, 4) = "Hour"
Worksheets("Board").Cells(1, 5) = "Stop"
intMainCounter = 1
intcounter = 4
booNewClass = True
strFirstDay = Format(Date, "M") & "/1/" & Format(Date, "YYYY")
' Build the array and fill it with all of the info from the workbook, this should
' greatly increase speed of the update.... i hope
Airframe
Hyd
Worksheets("Board").Range("A:E").Name = "Yeah"
Worksheets("Board").Range("Yeah").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=True
MsgBox "Baby steps", , "SFC Jones Rocks!!!"
Exit_My_Sub:
Exit Sub
Error_Handler:
MsgBox Err.Description, vbOKOnly, "Error Number " & Err.Number
Debug.Print Err.Description
GoTo Exit_My_Sub
End Sub
'******************
'Now starts the Airframe Breakdown
'******************
Sub Airframe()
Dim intCounterRowSchedule As Integer
Dim intCounterColumn As Integer
Dim curCellNew As Object
Dim curCellOld As Object
Dim intMainCounter As Integer
Dim strDate As String
Dim intMonthDays As Integer
Dim intMonthDaysCounter As Integer
Dim curCellDate As Object
Dim intCounterDate As Integer
Dim appExcel As Application
Dim sheetcount As Integer
Dim strName As String
Dim i As Integer, x As Integer, y As Integer, z As Integer
Dim arySheets() As String
Dim strLastCell As String
Dim dteDate As Date
Dim intcounter As Integer
Dim strFirstDay As String
Dim aryBook() As String
Dim intRow As Integer, intColumn As Integer, intSheet As Integer
Dim arySmall()
Dim aryBig()
Dim strAddress As String
Dim aryFinal(1 To 100, 1 To 256)
Dim intMaxRows As Integer
Dim booNewClass As Boolean
Dim strClass As String
Dim strClassList As String
Dim strClassDateList As String
Dim strClassHourList As String
Dim strClassStopList As String
Dim intMainCounterTop As Integer
Worksheets("Board").Range("A:E") = ""
Worksheets("Board").Cells(1, 1) = "Class"
Worksheets("Board").Cells(1, 2) = "Section"
Worksheets("Board").Cells(1, 3) = "Start"
Worksheets("Board").Cells(1, 4) = "Hour"
Worksheets("Board").Cells(1, 5) = "Stop"
intMainCounter = 1
intcounter = 4
booNewClass = True
strFirstDay = Format(Date, "M") & "/1/" & Format(Date, "YYYY")
' Build the array and fill it with all of the info from the workbook, this should
' greatly increase speed of the update.... i hope
'*******************'
' 15U '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_U_Class
End If
End If
Next i
Next x
Found_First_U_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15G(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15G(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_U_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) '- 1
For i = 2 To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 " & strClassList
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
intMainCounter = i + 1
'*******************'
' 15U3 RC '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3 RC.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_URC_Class
End If
End If
Next i
Next x
Found_First_URC_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15G(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15G(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_URC_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3 RC.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) - 1
For i = intMainCounter To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 RC " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 RC " & strClassList
Worksheets("Board").Cells(i, 2) = "AF"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
End Sub
'******************
'Now starts the Hyd Breakdown
'******************
Sub Hyd()
Dim intCounterRowSchedule As Integer
Dim intCounterColumn As Integer
Dim curCellNew As Object
Dim curCellOld As Object
Dim intMainCounter As Integer
Dim strDate As String
Dim intMonthDays As Integer
Dim intMonthDaysCounter As Integer
Dim curCellDate As Object
Dim intCounterDate As Integer
Dim appExcel As Application
Dim sheetcount As Integer
Dim strName As String
Dim i As Integer, x As Integer, y As Integer, z As Integer
Dim arySheets() As String
Dim strLastCell As String
Dim dteDate As Date
Dim intcounter As Integer
Dim strFirstDay As String
Dim aryBook() As String
Dim intRow As Integer, intColumn As Integer, intSheet As Integer
Dim arySmall()
Dim aryBig()
Dim strAddress As String
Dim aryFinal(1 To 100, 1 To 256)
Dim intMaxRows As Integer
Dim booNewClass As Boolean
Dim strClass As String
Dim strClassList As String
Dim strClassDateList As String
Dim strClassHourList As String
Dim strClassStopList As String
Dim intMainCounterTop As Integer
Dim iRow As Integer
Dim Ws As Object
strFirstDay = Format(Date, "M") & "/1/" & Format(Date, "YYYY")
' Build the array and fill it with all of the info from the workbook, this should
' greatly increase speed of the update.... i hope
'find first empty row in database
iRow = Ws.Cells(Ws.Rows.Count, 1) _
.End(xlUp).Row + 1
'*******************'
' 15U HYD '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_UHYD_Class
End If
End If
Next i
Next x
Found_First_UHYD_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15H(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15H(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_UHYD_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) '- 1
For i = 2 To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 " & strClassList
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
intMainCounter = i + 1
'*******************'
' 15U3 RC HYD '
'*******************'
strClassList = ""
strClassDateList = ""
strClassHourList = ""
strClassStopList = ""
Set appExcel = New Excel.Application
With appExcel
.Workbooks.Open "C:\Users\Gus\Desktop\skydrive-2014-01-31\15U3 RC.xls"
sheetcount = .Worksheets.Count
ReDim arySheets(1 To sheetcount, 1 To 3)
intMaxRows = 0
For i = 1 To sheetcount
arySheets(i, 1) = .Worksheets(i).Name
'arySheets(i, 2) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Cells.Value
arySheets(i, 3) = .Worksheets(arySheets(i, 1)).Range("A65536").End(xlUp).Row
If intMaxRows < arySheets(i, 3) Then
intMaxRows = arySheets(i, 3)
End If
Next i
' TEST CODE NOW****************
' Prepare big array
'intMaxRows = WorksheetFunction.Max(arySheets(sheetcount, 3))
ReDim aryBig(1 To sheetcount, 1 To 11, 1 To intMaxRows)
' Make array, then size it to length of sheet
For i = 1 To sheetcount
ReDim arySmall(1 To arySheets(i, 3), 1 To 11)
' Check if you need that sheet first
' Put sheet into array
arySmall = .Worksheets(arySheets(i, 1)).Range("A1:K" & intMaxRows & "").Value
' Transfer data from little array to big one...
For y = 1 To 11
For x = 1 To arySheets(i, 3)
aryBig(i, y, x) = arySmall(x, y)
Next x
Next y
Next i
' Now I need to build the Final array, which will be transferred to the calendar
' Search for the first sheet with an actual class, not the master, etc.
' Loop through column A for first date...
For x = 1 To sheetcount
For i = intMaxRows To 1 Step -1
If IsDate(aryBig(x, 1, i)) = True Then
'Exit For
If CDate(aryBig(x, 1, i)) >= Date Then ' If the date found is today or greater
GoTo Found_First_URCHYD_Class
End If
End If
Next i
Next x
Found_First_URCHYD_Class:
For x = x To sheetcount
For i = 2 To intMaxRows
' **************************************************
' Code here for all the classes that are ongoing or coming up...
'If intcounter <= 250 Then ' Keep the list to 25 so it will fit on schedule
If IsDate(aryBig(x, 1, i)) Then
If CDate(aryBig(x, 1, i)) >= CDate(strFirstDay) Then
For y = 4 To 11
If fncIs15H(CStr(Left(aryBig(x, y, i), 10))) = True Then
If booNewClass = True Then
booNewClass = False
If IsNull(arySheets(x, 1)) = False Then
strClassList = strClassList & vbNewLine & arySheets(x, 1) '& " " & Format(aryBig(x, 1, i), "dd - mmm")
strClassDateList = strClassDateList & vbNewLine & Format(aryBig(x, 1, i), "dd mmm yy")
strClassHourList = strClassHourList & vbNewLine & aryBig(x, y, 1) '& " Guess Hour: " & y - 3
'Run backwards through schedule looking for the end date
'*******************************************************
For intRow = intMaxRows To 2 Step -1
For intColumn = 11 To 4 Step -1
If fncIs15H(CStr(Left(aryBig(x, intColumn, intRow), 10))) = True Then
strClassStopList = strClassStopList & vbNewLine & Format(aryBig(x, 1, intRow), "dd mmm yy")
'strClassStopList = strClassStopList & vbNewLine & "Hour: " & intColumn - 3
intColumn = 4
intRow = 2
End If
Next intColumn
Next intRow
'End backwards check ***********************************
'*******************************************************
End If
End If
y = 11
End If
' *******************
'Debug.Print arySheets(x, 1) & " " & aryBig(x, 1, i)
Next y
End If
End If
' Else
' Exit For
'End If
Next i
End_of_URCHYD_Test:
'intcounter = intcounter + 1
booNewClass = True
Next x
.Workbooks("15U3 RC.xls").Close SaveChanges:=False
End With
Set appExcel = Nothing
intcounter = intcounter + 1
strClassList = Right(strClassList, Len(strClassList) - 2)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - 2)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - 2)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - 2)
intMainCounterTop = (intMainCounter + (Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare)))) - 1
For i = intMainCounter To intMainCounterTop
Worksheets("Board").Cells(i, 1) = "15U3 RC " & Left(strClassList, InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = Left(strClassDateList, InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 4) = Left(strClassHourList, InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
Worksheets("Board").Cells(i, 5) = Left(strClassStopList, InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
strClassList = Right(strClassList, Len(strClassList) - InStr(1, strClassList, Chr(13), vbBinaryCompare) - 1)
strClassDateList = Right(strClassDateList, Len(strClassDateList) - InStr(1, strClassDateList, Chr(13), vbBinaryCompare) - 1)
strClassHourList = Right(strClassHourList, Len(strClassHourList) - InStr(1, strClassHourList, Chr(13), vbBinaryCompare) - 1)
strClassStopList = Right(strClassStopList, Len(strClassStopList) - InStr(1, strClassStopList, Chr(13), vbBinaryCompare) - 1)
'Worksheets("Board").Cells(i, 3) = intMaxRows & " " & sheetcount
'Worksheets("Board").Cells(2, 4) = Len(strClassList) - Len(Replace(strClassList, Chr(13), "", 1, , vbBinaryCompare))
Next i
Worksheets("Board").Cells(i, 1) = "15U3 RC " & strClassList
Worksheets("Board").Cells(i, 2) = "HYD"
Worksheets("Board").Cells(i, 3) = strClassDateList
Worksheets("Board").Cells(i, 4) = strClassHourList
Worksheets("Board").Cells(i, 5) = strClassStopList
End Sub
'********************
'********************
