'-------------------一覧取得-----------------------------
Sub getRedmineGrid_Click()
Dim wb As Workbook
Dim sheet As Worksheet
Dim path As String
path = ThisWorkbook.path & "\issues.xls"
If Dir(path) = "" Then
FileCopy ThisWorkbook.path & "\back\issues.xls", path
Else
FileCopy path, ThisWorkbook.path & "\back\issues.xls"
End If
Dim idx As Integer
idx = 11
Dim csvWb As Workbook
Set csvWb = Workbooks.Open(path)
Set wb = Workbooks("進捗.xlsm")
Set sheet = wb.Sheets("進捗")
sheet.Range("B" & idx & ":Z1000").ClearContents
sheet.Range("D6") = Format(Date, "yyyymmdd")
For Each csvSheet In csvWb.Sheets
For i = 2 To 100
If csvSheet.Range("B" & i) = "" Then
Exit For
End If
If csvSheet.Range("B" & i) <> "#" Then
sheet.Range("B" & idx) = csvSheet.Range("B" & i)
sheet.Range("C" & idx) = csvSheet.Range("C" & i)
sheet.Range("D" & idx) = csvSheet.Range("D" & i)
sheet.Range("E" & idx) = csvSheet.Range("E" & i)
sheet.Range("F" & idx) = csvSheet.Range("F" & i)
sheet.Range("G" & idx) = csvSheet.Range("G" & i)
sheet.Range("H" & idx) = csvSheet.Range("H" & i)
sheet.Range("I" & idx) = csvSheet.Range("I" & i)
sheet.Range("J" & idx) = csvSheet.Range("J" & i)
sheet.Hyperlinks.Add Anchor:=sheet.Range("B" & idx), Address:="https://XXXXX/" & CStr(sheet.Range("B" & idx))
idx = idx + 1
End If
Next
Next
csvWb.Close
Kill path
MsgBox "ファイルのデータ取得した。"
End Sub
'-------------------週状態取得-----------------------------
Sub getLateData_Click()
Dim shetName As String
Dim sheet As Worksheet
Dim wb As Workbook
Dim sysDate As String
Dim maxRow As Integer
Dim sheetSample As Worksheet
sysDate = Format(Date, "yyyymmdd")
'sysDate7Befor = Format(Date - 7, "yyyymmdd")
Set wb = Workbooks("進捗.xlsm")
Set sheet = wb.Sheets("進捗")
Set sheetSample = wb.Sheets("sample")
sysDate7Befor = sheetSample.Range("D6")
shetName = "週(" & sysDate7Befor & "~" & sysDate & ")"
maxRow = sheet.Cells.Find("*", , , , xlByRows, xlPrevious).Row
'Sheet1.Cells.Find("*", , , , xlByColumns, xlPrevious).colum
If SheetIsExist(wb, shetName) Then
Application.DisplayAlerts = False
wb.Sheets(shetName).Delete
Application.DisplayAlerts = True
End If
wb.Sheets("sample").Copy after:=wb.Sheets("進捗")
ActiveSheet.Name = shetName
Dim sht As Worksheet
Set sht = wb.Sheets(shetName)
sht.Range("D6") = sysDate7Befor & "~" & sysDate
Dim idx As Integer
Dim startRow As Integer
Dim rowColor As String
idx = 11
startRow = idx - 3
For i = idx To maxRow
If sheet.Range("B" & i) = "" Then
Exit For
End If
If Trim(sysDate7Befor) <= dateToStr(sheet.Range("H" & i)) And dateToStr(sheet.Range("H" & i)) <= sysDate Then
sht.Range("B" & idx) = sheet.Range("B" & i)
sht.Range("C" & idx) = sheet.Range("C" & i)
sht.Range("D" & idx) = sheet.Range("D" & i)
sht.Range("E" & idx) = sheet.Range("E" & i)
sht.Range("F" & idx) = sheet.Range("F" & i)
sht.Range("G" & idx) = sheet.Range("G" & i)
sht.Range("H" & idx) = sheet.Range("H" & i)
sht.Range("I" & idx) = sheet.Range("I" & i)
sht.Range("J" & idx) = sheet.Range("J" & i)
rowColor = ""
If sht.Range("D" & idx) = "終了" Then
rowColor = "back"
End If
Call addStyle(sht, idx, startRow, rowColor)
sht.Hyperlinks.Add Anchor:=sht.Range("B" & idx), Address:="https://XXXXX/" & CStr(sht.Range("B" & idx))
idx = idx + 1
End If
Next
sheetSample.Range("D6") = sysDate
End Sub
Function dateToStr(str As String)
dateToStr = ""
If str = "" Then
dateToStr = ""
Exit Function
End If
str = Replace(str, "-", "/")
dateToStr = Split(str, "/")(0)
If Len(Split(str, "/")(1)) < 2 Then
dateToStr = dateToStr & "0" & Split(str, "/")(1)
Else
dateToStr = dateToStr & Split(str, "/")(1)
End If
If Len(Split(str, "/")(2)) < 2 Then
dateToStr = dateToStr & "0" & Split(str, "/")(2)
Else
dateToStr = dateToStr & Split(str, "/")(2)
End If
End Function
Function SheetIsExist(wbCheck As Workbook, shtNm As String)
SheetIsExist = False
On Error GoTo lab1
Set shetSheet = wbCheck.Sheets(shtNm)
If shetSheet Is Nothing Then
SheetIsExist = False
Else
SheetIsExist = True
End If
Set shetSheet = Nothing
Exit Function
lab1:
SheetIsExist = False
End Function