空的excel文件很大

Question

我一直在用 vba 编写一些代码来让 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

Answer 1

很多时候，当我复制粘贴时，它会带入需要删除但未清除的格式化单元格。我会尝试删除单元格而不是清除它们，否则您最终会得到数十万行没有任何值但占用空间的行。