zoukankan      html  css  js  c++  java
  • 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
    

      

  • 相关阅读:
    笔记44 Hibernate快速入门(一)
    tomcat 启用https协议
    笔记43 Spring Security简介
    笔记43 Spring Web Flow——订购披萨应用详解
    笔记42 Spring Web Flow——Demo(2)
    笔记41 Spring Web Flow——Demo
    Perfect Squares
    Factorial Trailing Zeroes
    Excel Sheet Column Title
    Excel Sheet Column Number
  • 原文地址:https://www.cnblogs.com/killclock048/p/9774027.html
Copyright © 2011-2022 走看看