cantona2
Posts: 3749
Joined: 5/21/2007 From: Gibraltar Status: offline
|
quote:
'' Čo treba dorobiť: '' '' - kontrolu či nechcem importovať už naimportované dáta '' '' '' '' '' '' '' Dim WITPAEPath, TMPPath, BATPath As String Dim ActionDate As Date Dim ImportFromDate, ImportToDate As Date Dim ScenNo, Side As String Sub MakeBAT() Dim fs, f Dim Line As String Line = "witploadAE.exe" & "/s" & ScenNo & " /e /b," Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.OpenTextFile(BATPath, 8, True, 0) f.Writeline ("c:") f.Writeline ("cd " + WITPAEPath + "\SCEN") f.Writeline (Line) f.Close End Sub Sub DelBAT() Dim fs, f Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFile BATPath End Sub Sub DeleteSheet(strSheetName As String) ' deletes a sheet named strSheetName in the active workbook Application.DisplayAlerts = False Sheets(strSheetName).Delete Application.DisplayAlerts = True End Sub Sub ImportDataWorksheets() Dim LastRow As Double Dim FileName, BookName, SheetName As String Dim MyBookName As String ''DeleteSheet ("Classes") ''DeleteSheet ("Ships") SheetName = "witpcls" + ScenNo BookName = SheetName + ".csv" FileName = WITPAEPath + "\SCEN\" + BookName MyBookName = ActiveWorkbook.Name Workbooks.Open (FileName), , , 2 Workbooks(BookName).Sheets(1).Copy _ After:=Workbooks(MyBookName).Sheets("AUX") Workbooks(BookName).Close SaveChanges:=False Worksheets(SheetName).Name = "Classes" SheetName = "witpshp" + ScenNo BookName = SheetName + ".csv" FileName = WITPAEPath + "\SCEN\" + SheetName Workbooks.Open (FileName), , , 2 Workbooks(BookName).Sheets(1).Copy _ After:=Workbooks(MyBookName).Sheets("AUX") Workbooks(BookName).Close SaveChanges:=False Worksheets(SheetName).Name = "Ships" Call PrepareShipsDB DeleteSheet ("Classes") DeleteSheet ("Ships") End Sub Sub PrepareShipsDB() Dim MyWrkSht As Worksheet Dim MyRange As Range Dim i, j, LastRow, LastRowClasses As Double Dim s As String Dim MyVarA, MyVarB ' Clear all Cells in ShipsDB to prepare sheet to new data LastRow = GetLastRow("ShipsDB") s = "A2:" & "K" & CStr(LastRow) Set MyWrkSht = ActiveWorkbook.Worksheets("ShipsDB") Set MyRange = MyWrkSht.Range(s) MyRange.ClearContents LastRowClasses = GetLastRow("Classes") LastRow = GetLastRow("Ships") i = 2 j = 2 Do While i <= LastRow If ActiveWorkbook.Worksheets("Ships").Cells(i, 3) <> 0 Then '' SHIP ID MyWrkSht.Cells(j, 1).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 1) '' SHIP NAME MyWrkSht.Cells(j, 2).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 2) '' CLASS ID MyWrkSht.Cells(j, 3).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 3) '' NATIONALITY ID MyWrkSht.Cells(j, 4).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 15) '' NATIONALITY MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 4).Value, Worksheets("AUX").Range("D2:D19")) MyVarB = Application.WorksheetFunction.HLookup("Nationality", Worksheets("AUX").Range("E2:E19"), MyVarA) MyWrkSht.Cells(j, 5).Value = MyVarB '' Type ID s = "A2:A" & CStr(LastRowClasses) MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 3).Value, Worksheets("Classes").Range(s)) MyWrkSht.Cells(j, 6).Value = ActiveWorkbook.Worksheets("Classes").Cells(MyVarA + 1, 3).Value '' Type MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 6).Value, Worksheets("AUX").Range("A2:A84")) MyVarB = Application.WorksheetFunction.HLookup("Type", Worksheets("AUX").Range("B2:B84"), MyVarA) MyWrkSht.Cells(j, 7).Value = MyVarB '' Full Name s = MyWrkSht.Cells(j, 7).Value & " " & MyWrkSht.Cells(j, 2).Value MyWrkSht.Cells(j, 8).Value = s '' Tonnage s = "A2:A" & CStr(LastRowClasses) MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 3).Value, Worksheets("Classes").Range(s)) MyWrkSht.Cells(j, 9).Value = ActiveWorkbook.Worksheets("Classes").Cells(MyVarA + 1, 22).Value j = j + 1 End If i = i + 1 Loop ''MyWrkSht.Range(s).FormatConditions Set MyRange = Nothing Set MyWrkSht = Nothing End Sub Sub LoadConfig() WITPAEPath = Worksheets("Configuration").Cells(3, 3).Value TMPPath = Worksheets("Configuration").Cells(4, 3).Value + "\RCMTMP.txt" BATPath = Worksheets("Configuration").Cells(3, 3).Value + "\SCEN\DUMPSCEN.bat" ImportFromDate = Worksheets("Configuration").Cells(5, 3).Value ImportToDate = Worksheets("Configuration").Cells(6, 3).Value ScenNo = Worksheets("Configuration").Cells(7, 3).Value Side = Worksheets("Configuration").Cells(8, 3).Value End Sub Sub LoadDB() Dim RetVar Dim ImWrkSht As Worksheet Dim ImRange As Range Dim MsgBoxResponse As String LoadConfig MakeBAT RetVar = Shell(BATPath, vbNormalFocus) MsgBoxResponse = MsgBox("Wait for dumping end, then press OK", vbOKOnly) DelBAT ImportDataWorksheets End Sub Function GetLastRow(WrkShtName As String) As Double Dim MyWrkSht As Worksheet Dim MyRange As Range Set MyWrkSht = ActiveWorkbook.Worksheets(WrkShtName) Set MyRange = MyWrkSht.UsedRange GetLastRow = MyRange.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set MyRange = Nothing Set MyWrkSht = Nothing End Function Sub ImportReport() Dim Path As String LoadConfig Path = WITPAEPath + "\SAVE\combatreport2.txt" OpenCombatReport (Path) Path = WITPAEPath + "\SAVE\" & Side & "operationsreport2.txt" OpenOperationsReport (Path) Call RemoveDuplicates Call RefreshPivotTables End Sub Sub RemoveDuplicates() Dim MyWrkSht As Worksheet Dim MyRange As Range Dim a Set MyWrkSht = ActiveWorkbook.Worksheets("Combat Reports") Set MyRange = MyWrkSht.UsedRange MyRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes Set MyRange = Nothing Set MyWrkSht = Nothing End Sub Sub RefreshPivotTables() Dim s As String Dim LastRow As Double LastRow = GetLastRow("Combat Reports") s = "Combat Reports!R1C1:R" & CStr(LastRow) & "C7" ActiveWorkbook.Worksheets("MONTHS").PivotTables("MonthReview").SourceData = s ActiveWorkbook.Worksheets("MONTHS").PivotTables("SubmarineReview").SourceData = s ActiveWorkbook.Worksheets("MONTHS").PivotTables("MonthReview").RefreshTable ActiveWorkbook.Worksheets("MONTHS").PivotTables("SubmarineReview").RefreshTable End Sub Sub OpenOperationsReport(ORPath As String) Dim fs, f Dim LastRow As Double Dim ShipName As String Dim SunkDate As Date Dim MyLine Dim s As String Dim MyWrkSht As Worksheet Dim MyRange As Range Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.OpenTextFile(ORPath, 1, 0) MyLine = "" Set MyWrkSht = ActiveWorkbook.Worksheets("Combat Reports") Set MyRange = MyWrkSht.UsedRange LastRow = GetLastRow("Combat Reports") Do While f.AtEndOfStream = False MyLine = f.Readline If InStr(1, MyLine, "reported to have been sunk", vbTextCompare) > 0 Then ShipName = GetSunkShipName(MyLine) SunkDate = GetSunkShipDate(MyLine) Set MyRange = MyWrkSht.Rows(1) i = 2 Do While i <= LastRow If MyWrkSht.Cells(i, 1).Value = SunkDate Then If MyWrkSht.Cells(i, 4).Value = ShipName Then MyWrkSht.Cells(i, 6).Value = "SUNK" i = LastRow End If End If i = i + 1 Loop End If If InStr(1, MyLine, "Previous report of sinking", vbTextCompare) > 0 Then ShipName = GetFalseReportedShipName(MyLine) ''SunkDate = GetSunkShipDate(MyLine) Set MyRange = MyWrkSht.Rows(1) i = LastRow Do While (MyWrkSht.Cells(i, 4).Value <> ShipName) And (i > 1) i = i - 1 Loop If MyWrkSht.Cells(i, 4).Value = ShipName Then MyWrkSht.Cells(i, 6).Value = "FR SUNK" End If Loop f.Close End Sub Function GetSunkShipName(MyLine) As String Dim i As Long i = InStr(1, MyLine, "is reported", vbTextCompare) - 2 GetSunkShipName = Left(MyLine, i) End Function Function GetShipShortName(LongShipName As String) As String Dim i As Double i = InStr(LongShipName, " ") GetShipShortName = Right(LongShipName, Len(LongShipName) - i) End Function Function GetFalseReportedShipName(MyLine) As String Dim i, j As Long Dim s As String i = InStr(1, MyLine, "of sinking of", vbTextCompare) + 13 j = Len(MyLine) s = Right(MyLine, j - i) i = InStr(1, s, "incorrect", vbTextCompare) - 2 GetFalseReportedShipName = Left(s, i) End Function Function GetSunkShipDate(ShipLine) As Date Dim sDate As String Dim s, sDay, sMonth, sYear As String sDate = Right(ShipLine, 12) sYear = Right(sDate, 4) sDay = Mid(sDate, 5, 2) sMonth = GetMonth(Left(sDate, 3)) s = sDay + "." + sMonth + "." + sYear GetSunkShipDate = DateValue(s) End Function Sub ImportArchiveReports() Dim ArchivePath, Path As String Dim m As Integer Dim YY, MM, DD, s As String Dim iDay As Date LoadConfig ArchivePath = Worksheets("Configuration").Cells(3, 3).Value + "\SAVE\archive" iDay = ImportFromDate '' Sem by mala ešte prísť kontrola, či už reporty z daného dátumu neboli naimportované Do While iDay <= ImportToDate DD = Day(iDay) If Len(DD) < 2 Then DD = "0" & DD m = Month(iDay) If m < 10 Then MM = "0" & CStr(m) Else: MM = CStr(m) End If YY = Year(iDay) YY = Right(YY, 2) Path = ArchivePath + "\combatreport_" + CStr(YY) + CStr(MM) + CStr(DD) + ".txt" If Dir(Path) <> "" Then OpenCombatReport (Path) Path = ArchivePath & "\" & Side & "operationsreport_" + CStr(YY) + CStr(MM) + CStr(DD) + ".txt" If Dir(Path) <> "" Then OpenOperationsReport (Path) iDay = iDay + 1 Loop Call RemoveDuplicates Call RefreshPivotTables End Sub Sub OpenCombatReport(ReportPath As String) Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim tf, fs, f Dim Path, Line As String Dim i As Integer Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.OpenTextFile(ReportPath, 1, 0) Set tf = fs.OpenTextFile(TMPPath, 8, True, 0) i = 1 ParserStream = "" Do While f.AtEndOfStream = False Line = f.Readline If Line = "--------------------------------------------------------------------------------" Then ' call parser Sub with ParserStream argument tf.Close ParseModule (TMPPath) fs.DeleteFile (TMPPath) Set tf = fs.OpenTextFile(TMPPath, 8, True, 0) Else If IsNewDay(Line) Then ActionDate = GetDayDate(Line) tf.Writeline (Line) End If i = i + 1 Loop Worksheets("Configuration").Cells(10, 3).Value = ActionDate f.Close End Sub Function IsNewDay(s As String) As Boolean If Mid(s, 1, 12) = "AFTER ACTION" Then IsNewDay = True Else: IsNewDay = False End If End Function Function GetDayDate(DateLine As String) As Date Dim LineL As Integer Dim s, sMonth, sDay, sYear As String LineL = Len(DateLine) s = Mid(DateLine, LineL - 9, 10) sMonth = GetMonth(Mid(s, 1, 3)) sDay = Mid(s, 5, 2) sYear = Mid(s, 9, 2) s = sDay + "." + sMonth + "." + "19" + sYear GetDayDate = DateValue(s) End Function Sub ParseModule(TMPPath As String) Dim Line, Ship As String Dim fs, f Dim arr Dim s Dim RowB, RowD As String Dim JapArr(15) As String Dim AllArr(15) As String Dim i As Integer Dim LastRow& Dim isJapAttacker As Boolean Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.OpenTextFile(TMPPath, 1, 0) Line = f.Readline i = 0 isJapAttacker = False Select Case Mid(Line, 1, 3) Case "Sub" ' Parse Ship Names from rcm_tmp.txt to JappArr and AllArr collections of ship names Do While f.AtEndOfStream = False Line = f.Readline If InStr(Line, "Japanese Ships") > 0 Then Do Until Line = " " Line = f.Readline arr = Split(Line, ",", , 1) If (UBound(arr) > 0 Or InStr(Line, "SS")) Then Ship = arr(0) Ship = Mid(Ship, 7) JapArr(i) = Ship ' if Jap ship is SS then set isJapAttacker as true If InStr(Line, "SS") Then isJapAttacker = True i = i + 1 End If Loop i = 0 End If If InStr(Line, "Allied Ships") > 0 Then Do Until Line = " " Line = f.Readline arr = Split(Line, ",", , 1) If (UBound(arr) > 0 Or InStr(Line, "SS")) Then Ship = arr(0) Ship = Mid(Ship, 7) AllArr(i) = Ship ' if isJapAttacker is set as true (jap ship was SS) AND Allied ship is SS then if Allied ship is NOT damaged then isJapAttacker set to false If isJapAttacker Then If (UBound(arr) = 0 And InStr(Line, "SS")) Then isJapAttacker = False End If i = i + 1 End If Loop End If Loop If isJapAttacker Then i = 0 Do While AllArr(i) <> "" Call WriteCRRow(ActionDate, JapArr(0), AllArr(i)) i = i + 1 Loop Else i = 0 Do While JapArr(i) <> "" Call WriteCRRow(ActionDate, AllArr(0), JapArr(i)) i = i + 1 Loop End If isJapAttacker = False Case "ASW" Do While f.AtEndOfStream = False Line = f.Readline If InStr(Line, "Japanese Ships") > 0 Then Do Until Line = " " Line = f.Readline arr = Split(Line, ",", , 1) If (UBound(arr) > 0 Or InStr(Line, "SS")) Then Ship = arr(0) Ship = Mid(Ship, 7) JapArr(i) = Ship ' if Jap ship is SS then set isJapAttacker as true If InStr(Line, "SS") Then isJapAttacker = True i = i + 1 End If Loop i = 0 End If If InStr(Line, "Allied Ships") > 0 Then Do Until Line = " " Line = f.Readline arr = Split(Line, ",", , 1) If (UBound(arr) > 0 Or InStr(Line, "SS")) Then Ship = arr(0) Ship = Mid(Ship, 7) AllArr(i) = Ship ' if isJapAttacker is set as true (jap ship was SS) AND Allied ship is SS then if Allied ship is NOT damaged then isJapAttacker set to false If isJapAttacker Then If (UBound(arr) = 0 And InStr(Line, "SS")) Then isJapAttacker = False End If i = i + 1 End If Loop End If Loop If isJapAttacker Then i = 0 Do While AllArr(i) <> "" Call WriteCRRow(ActionDate, JapArr(0), AllArr(i)) i = i + 1 Loop Else i = 0 Do While JapArr(i) <> "" Call WriteCRRow(ActionDate, AllArr(0), JapArr(i)) i = i + 1 Loop End If isJapAttacker = False Case Else End Select i = 0 f.Close End Sub Function GetMonth(ParsedDateString As String) As String Select Case ParsedDateString Case "Jan" GetMonth = "01" Case "Feb" GetMonth = "02" Case "Mar" GetMonth = "03" Case "Apr" GetMonth = "04" Case "May" GetMonth = "05" Case "Jun" GetMonth = "06" Case "Jul" GetMonth = "07" Case "Aug" GetMonth = "08" Case "Sep" GetMonth = "09" Case "Oct" GetMonth = "10" Case "Nov" GetMonth = "11" Case "Dec" GetMonth = "12" End Select End Function Private Sub WriteCRRow(RowA As Date, RowB As String, RowD As String) Dim MyWrkSht As Worksheet Dim MyRange As Range Dim LastRow&, LastRowShipsDB Dim s, ss As String Dim MyVarA, i As Double Dim err As Variant Set MyWrkSht = ActiveWorkbook.Worksheets("Combat Reports") Set MyRange = MyWrkSht.UsedRange LastRow = MyRange.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row LastRowShipsDB = GetLastRow("ShipsDB") s = "H1:H" & CStr(LastRowShipsDB) MyVarA = Application.WorksheetFunction.Match(RowB, Worksheets("ShipsDB").Range(s), 0) i = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 4).Value If (Side = "a" And i > 3) Or (Side = "j" And i < 3) Then '' Date MyWrkSht.Cells(LastRow + 1, 1).Value = RowA '' Long Submarine Name MyWrkSht.Cells(LastRow + 1, 2).Value = RowB '' Submarine Nation MyWrkSht.Cells(LastRow + 1, 3).Value = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 5).Value '' Long Victim Name MyWrkSht.Cells(LastRow + 1, 4).Value = RowD '' Tonnage '' if ship type is same MATCH then write tonnage s = "H1:H" & CStr(LastRowShipsDB) err = Application.Match(RowD, Worksheets("ShipsDB").Range(s), 0) If IsError(err) Then s = "B1:B" & CStr(LastRowShipsDB) ss = GetShipShortName(RowD) MyVarA = Application.Match(ss, Worksheets("ShipsDB").Range(s), 0) MyWrkSht.Cells(LastRow + 1, 5).Value = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 9).Value '' If ship type is diferent then lookup next short name match Else s = "H1:H" & CStr(LastRowShipsDB) MyVarA = Application.Match(RowD, Worksheets("ShipsDB").Range(s), 0) MyWrkSht.Cells(LastRow + 1, 5).Value = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 9).Value End If MyWrkSht.Cells(LastRow + 1, 6).Value = "DAMAGED" If Len(Month(RowA)) < 2 Then ss = Year(RowA) & "/0" & Month(RowA) Else: ss = Year(RowA) & "/" & Month(RowA) End If MyWrkSht.Cells(LastRow + 1, 7).Value = ss End If Set MyRange = Nothing Set MyWrkSht = Nothing End Sub Here is the debug dialouge
_____________________________
1966 was a great year for English Football...Eric was born
|