0
我一直在寫一些代碼以使excel打開工作簿，從那裏獲取信息，將其臨時粘貼到文件中並使用該數據製作電子郵件併發送它。之後，他清除所有內容，剩下一個空文件。空的excel文件具有巨大的尺寸
雖然只有一個按鈕（不是ActiveX控件），只有一個用戶窗體，但該文件爲27MB。而之前是400kb。我不知道發生了什麼事。任何想法如何解決這個問題，並再次減少它？因爲這個文件是爲了減少發送電子郵件的時間，但是如果打開文件需要很長時間，因爲它贏得的時間非常短，因此效率不高。
我使用的程序是Excel 2010.
在此先感謝！
代碼：
Private Sub BtnGo_Click()
Dim i As Integer, j As Integer, k As Integer, l As Integer, LastRow, wb As Workbook, TargetBook As Workbook, Doc(500), Revision(500), DocName(500), UpdateDate(500)
Dim Tekst As String, DocType As String
Dim NietGevonden
Set TargetBook = ThisWorkbook
'Controleren of alles ingevuld is
If TxtNumberDoc.Text = "" Then
NietGevonden = MsgBox("Aantal doc niet ingegeven." & vbCrLf & "Gelieve opnieuw te proberen.", vbCritical, "# doc!")
Exit Sub
End If
If OptVincent.Value = False And OptRuben.Value = False Then
NietGevonden = MsgBox("Geen naam geselecteerd." & vbCrLf & "Gelieve opnieuw te proberen.", vbCritical, "Geen naam!")
Exit Sub
End If
TargetBook.ActiveSheet.Range("A:C").NumberFormat = "@"
TargetBook.ActiveSheet.Range("D:D").NumberFormat = "dd/mm/yyyy"
If OptVincent.Value = True Then
TargetBook.ActiveSheet.Range("G25").Value = "Vincent"
Else
TargetBook.ActiveSheet.Range("G25").Value = "Ruben"
End If
'Doc system openen
Set wb = Workbooks.Open("****")
'Juiste tablad openen
If OptQN.Value = True Then
wb.Sheets("DOC_QN").Activate
TargetBook.ActiveSheet.Range("G26").Value = "QN"
TargetBook.ActiveSheet.Range("G27").Value = "Quality Notes"
TargetBook.ActiveSheet.Range("G28").Value = "Quality Note"
GoTo Zoeken
End If
If OptQF.Value = True Then
wb.Sheets("DOC_QF").Activate
TargetBook.ActiveSheet.Range("G26").Value = "QF"
TargetBook.ActiveSheet.Range("G27").Value = "Quality Forms"
TargetBook.ActiveSheet.Range("G28").Value = "Quality Form"
GoTo Zoeken
End If
If OptQAP.Value = True Then
wb.Sheets("DOC_QAP").Activate
TargetBook.ActiveSheet.Range("G26").Value = "QAP"
TargetBook.ActiveSheet.Range("G27").Value = "Quality Assurance Plans"
TargetBook.ActiveSheet.Range("G28").Value = "Quality Assurance Plan"
GoTo Zoeken
End If
If OptQL.Value = True Then
wb.Sheets("DOC_QL").Activate
TargetBook.ActiveSheet.Range("G26").Value = "QL"
TargetBook.ActiveSheet.Range("G27").Value = "Quality Lists"
TargetBook.ActiveSheet.Range("G28").Value = "Quality List"
GoTo Zoeken
End If
If OptQCP.Value = True Then
wb.Sheets("DOC_QCP").Activate
TargetBook.ActiveSheet.Range("G26").Value = "QCP"
TargetBook.ActiveSheet.Range("G27").Value = "Quality Customer Plans"
TargetBook.ActiveSheet.Range("G28").Value = "Quality Customer Plan"
GoTo Zoeken
End If
If OptPF.Value = True Then
wb.Sheets("DOC_PF").Activate
TargetBook.ActiveSheet.Range("G26").Value = "PF"
TargetBook.ActiveSheet.Range("G27").Value = "Process Forms"
TargetBook.ActiveSheet.Range("G28").Value = "Proces Form"
GoTo Zoeken
End If
If OptPL.Value = True Then
wb.Sheets("DOC_PL").Activate
TargetBook.ActiveSheet.Range("G26").Value = "PL"
TargetBook.ActiveSheet.Range("G27").Value = "Process Lists"
TargetBook.ActiveSheet.Range("G28").Value = "Process List"
GoTo Zoeken
End If
If OptOPM.Value = True Then
wb.Sheets("DOC_OPM").Activate
TargetBook.ActiveSheet.Range("G26").Value = "OPM"
TargetBook.ActiveSheet.Range("G27").Value = "Operation Manuals"
TargetBook.ActiveSheet.Range("G28").Value = "Operation Manual"
GoTo Zoeken
End If
If OptTS.Value = True Then
wb.Sheets("DOC_TSY").Activate
TargetBook.ActiveSheet.Range("G26").Value = ""
TargetBook.ActiveSheet.Range("G27").Value = "Training Syllabis"
TargetBook.ActiveSheet.Range("G28").Value = "Training Syllabi"
GoTo Zoeken
End If
If OptREx.Value = True Then
wb.Sheets("DOC_REX").Activate
TargetBook.ActiveSheet.Range("G26").Value = "REx"
TargetBook.ActiveSheet.Range("G27").Value = "Retour d'Expériences"
TargetBook.ActiveSheet.Range("G28").Value = "Retour d'Expérience"
GoTo Zoeken
End If
If OptTC.Value = True Then
wb.Sheets("DOC_TrC").Activate
TargetBook.ActiveSheet.Range("G26").Value = ""
TargetBook.ActiveSheet.Range("G27").Value = "Training Courses"
TargetBook.ActiveSheet.Range("G28").Value = "Training Course"
GoTo Zoeken
End If
Zoeken:
'Bepalen hoeveel doc er gevraagd zijn
i = TxtNumberDoc.Text
For j = 1 To i
Doc(j) = InputBox(TargetBook.ActiveSheet.Range("G26").Value & " #?" & vbCrLf & "Number only.", "Insert Doc number")
Next j
j = 1
k = 5 'rij met eerste nummer
l = 1 'rijnummer targetbook
LastRow = wb.ActiveSheet.Range("C5").End(xlDown).Row
'data overzetten
DocType = TargetBook.ActiveSheet.Range("G28").Value
Do
If wb.ActiveSheet.Range("B" & k).RowHeight <> 0 Then
Tekst = wb.ActiveSheet.Range("C" & k).Value
If Doc(j) = Tekst Then
TargetBook.ActiveSheet.Range("A" & l).Value = Doc(j)
TargetBook.ActiveSheet.Range("B" & l).Value = wb.ActiveSheet.Range("D" & k).Value
TargetBook.ActiveSheet.Range("C" & l).Value = wb.ActiveSheet.Range("E" & k).Value
TargetBook.ActiveSheet.Range("D" & l).Value = wb.ActiveSheet.Range("F" & k).Value
j = j + 1
l = l + 1
k = 5
Else
k = k + 1
End If
Else
k = k + 1
End If
If j = i + 1 Then GoTo Vervolg 'Vervroegd laten stoppen als alles gevonden is
Loop Until k = LastRow + 1
'Als Doc niet gevonden is =>
NietGevonden = MsgBox(DocType & " " & Doc(j) & " niet gevonden." & vbCrLf & "Wil u de actie afbreken?" & vbCrLf & _
"(bij nee zal deze " & DocType & " overgeslagen worden.)", vbYesNo + vbExclamation + vbDefaultButton2, "Error, " & DocType & " " & Doc(j) & " niet gevonden.")
If NietGevonden = vbYes Then
wb.Close False
ActiveWorkbook.ActiveSheet.Range("A:G").Clear
Exit Sub
Else
j = j + 1
k = 5
GoTo Zoeken
End If
Vervolg:
wb.Close False
Me.Hide
SendMail
End Sub
代碼2：
Dim OutApp As Object
Dim OutMail As Object
Dim ontvanger As String
Dim Titel As String
Dim Name As String
Dim Signature As String
Dim LastRow As Integer
Dim i As Integer
Dim InhoudDoc As String
Dim InhoudMail As String
Dim Datum As String
Dim Maand As String
Dim Dag As String
Dim Jaar As String
Dim CheckDag As String
Dim Enkelvoud As String
Dim Meervoud As String
Dim Afkorting As String
Enkelvoud = ActiveWorkbook.ActiveSheet.Range("G28").Value
Meervoud = ActiveWorkbook.ActiveSheet.Range("G27").Value
Afkorting = ActiveWorkbook.ActiveSheet.Range("G26").Value
LastRow = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
ontvanger = "#D_SSB UsersList"
Name = ActiveWorkbook.ActiveSheet.Range("G25").Value
'Signature namaken
Select Case Name
Case Is = "Vincent"
Signature = ****
Case Else
Signature = ****
End Select
If LastRow > 1 Then
Titel = "Please be informed that several new " & Meervoud & " have been accepted and published on Documentary System.xlsm (located on ****)."
For i = 1 To LastRow
'Eerst datum samenstellen
Datum = ActiveWorkbook.ActiveSheet.Range("D" & i).Value
Dag = Left(Datum, 2)
If Right(Dag, 1) = "/" Then
Datum = Left(Datum, 4)
Dag = "0" & Left(Dag, 1)
Else
Datum = Left(Datum, 5)
End If
Datum = Right(Datum, 2)
Select Case Datum
Case Is = "01"
Maand = "January"
Case Is = "02"
Maand = "February"
Case Is = "03"
Maand = "March"
Case Is = "04"
Maand = "April"
Case Is = "05"
Maand = "May"
Case Is = "06"
Maand = "June"
Case Is = "07"
Maand = "July"
Case Is = "08"
Maand = "August"
Case Is = "09"
Maand = "September"
Case Is = "10"
Maand = "October"
Case Is = "11"
Maand = "November"
Case Is = "12"
Maand = "December"
End Select
Datum = ActiveWorkbook.ActiveSheet.Range("D" & i).Value
Jaar = "20" & Right(Datum, 2)
InhoudDoc = InhoudDoc & Afkorting & ActiveWorkbook.ActiveSheet.Range("A" & i).Value & " Revision " & ActiveWorkbook.ActiveSheet.Range("B" & i) & _
" Dated " & Maand & " " & Dag & ", " & Jaar & ": " & "<b>" & ActiveWorkbook.ActiveSheet.Range("C" & i).Value & "</b>" & "<br>"
Next i
Else
'Eerst datum samenstellen
Datum = ActiveWorkbook.ActiveSheet.Range("D1").Value
Dag = Left(Datum, 2)
If Right(Dag, 1) = "/" Then
Datum = Left(Datum, 4)
Dag = "0" & Left(Dag, 1)
Else
Datum = Left(Datum, 5)
End If
Datum = Right(Datum, 2)
Select Case Datum
Case Is = "01"
Maand = "January"
Case Is = "02"
Maand = "February"
Case Is = "03"
Maand = "March"
Case Is = "04"
Maand = "April"
Case Is = "05"
Maand = "May"
Case Is = "06"
Maand = "June"
Case Is = "07"
Maand = "July"
Case Is = "08"
Maand = "August"
Case Is = "09"
Maand = "September"
Case Is = "10"
Maand = "October"
Case Is = "11"
Maand = "November"
Case Is = "12"
Maand = "December"
End Select
Datum = ActiveWorkbook.ActiveSheet.Range("D1").Value
Jaar = "20" & Right(Datum, 2)
Titel = "Please be informed that " & Enkelvoud & " " & Afkorting & " " & ActiveWorkbook.ActiveSheet.Range("A" & 1).Value & " has been revised, accepted and published on Documentary System.xlsm (located on ****)."
InhoudDoc = Afkorting & ActiveWorkbook.ActiveSheet.Range("A" & 1).Value & " Revision " & ActiveWorkbook.ActiveSheet.Range("B" & 1) & _
" Dated " & Maand & " " & Dag & ", " & Jaar & ": " & "<b>" & ActiveWorkbook.ActiveSheet.Range("C" & 1).Value & "</b>" & "<br>"
End If
InhoudMail = "<p>" & "Dear all" & "</p>" & "<p>" & Titel & "</p>" & "<br>" & "<p>" & InhoudDoc & "</p>" & "<br>" & "Best regards, " & "<br>" & Name & "<br>" & "<br>" & Signature
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ontvanger
.CC = ""
.BCC = ""
.Subject = Titel
.HTMLBody = InhoudMail
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveWorkbook.ActiveSheet.Range("A:G").Value = ""
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
向我們展示代碼，我們不能真正幫助，而不會看到最新消息 – SaggingRufus
有沒有去:) – KawaRu
您是否嘗試將數據不放入包含代碼的工作簿中，而放入另一個新的電子郵件已發送？ – Variatus