'-------------------一覧取得----------------------------- 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 & "ackissues.xls", path Else FileCopy path, ThisWorkbook.path & "ackissues.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