excel通过宏|vba导出数据为sql及图片导出到文件夹

最新推荐文章于 2023-10-24 09:46:53 发布

zepcjsj0801

最新推荐文章于 2023-10-24 09:46:53 发布

阅读量1k

点赞数 1

分类专栏：开发问题

本文链接：https://blog.csdn.net/zepcjsj0801/article/details/109294989

版权

开发问题专栏收录该内容

21 篇文章 0 订阅

订阅专栏

这几天结尾一个项目，项目最后客户要导入数据，一个70多M的excel，数据五千多条，主要容量是因为excel内每条数据对应一个图片，导致excel过大，并且导入系统也不太显示。摸索几天，想到一个这样的方法。
用excel的宏拼接导出sql语句。自动导出excel的图片到外部的一个文件夹，然后上传到服务器。

Function clearChar(no As String)
    no = Replace(no, Chr(10), "")
    no = Replace(no, Chr(13), "")
    no = Replace(no, " ", "")
    no = Replace(no, "'", "\'")
    clearChar = no
End Function

Sub saveSql()
      Dim objSht  As Object
      Dim i, strTemp
   Dim today As String
   today = Year(Date) & Month(Date) & Day(Date)
   
   Open ThisWorkbook.Path & "\sql.txt" For Output As #1 '导出数据存放位置，excel所在目录下
   Print #1, "insert into sb_shangbiao(catid,status,no,time1,sbstate,title,sbcat,thumb,description,sbshiyong,price,sbcat2)values"
   Dim sheet As Integer
    For sheet = 1 To Worksheets.Count
        Set objSht = Sheets(sheet)
        
        i = 3
        Do
           strTemp = clearChar(objSht.Cells(i, 2).Text)
           
           If (strTemp = "") Then Exit Do '如果没有某个字段，就跳过
           
           strTemp = "(14,99,'" & strTemp & "','" & clearChar(objSht.Cells(i, 3)) & "','" & clearChar(objSht.Cells(i, 4)) & "','" & clearChar(objSht.Cells(i, 5)) & "','" & clearChar(objSht.Cells(i, 6) ) & "','/uploadfile/logo" & today & "/" & clearChar(objSht.Cells(i, 2)) & ".jpg','" & clearChar(objSht.Cells(i, 8)) & "','" & clearChar(objSht.Cells(i, 9)) & "','" & clearChar(objSht.Cells(i, 10)) & "','" & clearChar(objSht.Cells(i, 11)) & "'),"
           Print #1, strTemp
           i = i + 1
        Loop
        
        Set objSht = Nothing
   Next
   Close #1
   MsgBox "数据导出完毕！", vbInformation
End Sub



Sub saveImg()
    Dim objSht  As Object
    Dim i As Integer, minHeight As Integer, sh As Shape
    Dim FileName As String
    Dim today As String
   today = Year(Date) & Month(Date) & Day(Date)
   Dim folder As String
    
    Open ThisWorkbook.Path & "\log.txt" For Output As #1
    
    minHeight = ActiveSheet.Cells(1, 1).Height + ActiveSheet.Cells(2, 1).Height
    folder = ThisWorkbook.Path & "\sblogo" & today
    On Error Resume Next
    MkDir folder
    Dim sheet As Integer
    For sheet = 38 To Worksheets.Count
        Set objSht = Sheets(sheet)
        For i = 1 To objSht.Shapes.Count
            
            Set shp = objSht.Shapes(i)
            
             strTemp = sheet & "-" & i & "-" & clearChar(objSht.Cells(shp.TopLeftCell.Row, 2)) & "-" & shp.Height & "-" & objSht.Name
            Print #1, strTemp
           If shp.Top > minHeight And shp.Height > 0 And shp.Width > 0 Then
               
               FileName = folder & "\" & clearChar(objSht.Cells(shp.TopLeftCell.Row, 2)) & ".jpg"
      
            Print #1, FileName
                shp.Copy
    
                With objSht.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart '如果报错是因为图片不合法，具体原因未知
                    .Paste
                    .Export FileName, "jpg" 
    
                    .Parent.Delete
    
                End With
           
            End If

    
        Next
     '  Sleep 500
  Next
  Close #1
  MsgBox "图片导出完毕！", vbInformation
End Sub```