• 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
    

      

  • 相关阅读:
    update语句
    java List和数组相互转换方法
    mysql查最大字符串
    Mybatis各种模糊查询
    mysql 递归查询父节点 和子节点
    String类型根据逗号分隔转为list
    This function has none of DETERMINISTIC, NO SQL, or READS SQL DATA in its de 错误解决办法
    java中String数组和List的互相转化
    实现List集合中数据逆序排列
    String字符串去掉双引号
  • 原文地址:https://www.cnblogs.com/killclock048/p/9774027.html
Copyright © 2020-2023  润新知