• 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 & "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
    

      

  • 相关阅读:
    设置linux查看历史命令显示执行时间
    CentOS7.6操作系统安装实例以及Linux版本、哲学思想介绍
    JavaScript 数据结构1
    原生js 正则表达
    js Event事件
    引用类型: 归并方法
    引用类型: 迭代方法
    引用类型 位置方法 indexOf()和 lastIndexOf()
    引用类型 操作方法
    引用类型 重排序方法
  • 原文地址:https://www.cnblogs.com/killclock048/p/9774027.html
Copyright © 2020-2023  润新知