Adding data to the exisitng data error

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

'********************

'********************
 

Some videos you may like

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

Watch MrExcel Video

Forum statistics

Threads
1,123,118
Messages
5,599,817
Members
414,341
Latest member
Mohammedsobhey

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top