excel通過宏|vba導出資料為sql及圖檔導出到檔案夾

這幾天結尾一個項目，項目最後客戶要導入資料，一個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```