VBA实现打开Excel文件读取内容拷贝Format且加超链接

'-------------------一覧取得-----------------------------
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

  

猜你喜欢

转载自www.cnblogs.com/killclock048/p/9774027.html