时间戳

首页 > 解决方案 > 添加 VBA（从其他工作表中提取数据）例程后 Excel 文件变得太重

excel - 添加 VBA（从其他工作表中提取数据）例程后 Excel 文件变得太重

问题描述

我正在通过将其他工作表中的数据复制到主文件中来自动化 Excel 模型。我有一点问题，添加代码后文件从 25mb 变为 60mb，没有更改内容，只添加代码。您可以在下面找到我如何自动化导入的片段

Sub copytest() 'Procedure for retrieving data from the sourcefiles

    Dim wbTarget, wbSource As Workbook
    Dim target As Object
    Dim pathSource, fileName As String
    Dim xlApp As Application
    Dim lastRow As Long

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    'path where the data source folders are located (please keep all of them in the same directory)
    pathSource = "C:\Users\vferraz\Desktop\crm stock\RAPOARTE IMPORTANTE\18.02\Rapoarte pentru Handsets\"
    Set wbTarget = ThisWorkbook

    Set xlApp = CreateObject("Excel.Application")
    xlApp.DisplayAlerts = False
    Application.CutCopyMode = False

    'Stock 0001
    Set wbSource = xlApp.Workbooks.Open(pathSource & "Stoc 0001.xls")
    wbSource.Sheets(1).UsedRange.Copy
    wbSource.Close
    Set target = wbTarget.Sheets("Stock 0001")
    target.UsedRange.Clear
    Range("A1").Select
    target.Paste

    xlApp.Quit
    Set wbSource = Nothing
    Set xlApp = Nothing

    ThisWorkbook.Sheets("Mastersheet").Activate

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

在上面的片段中，我只添加了一个文件（Stock 0001）的解析，但对其他 10-15 个文件执行相同的方法。

有没有人有任何想法可以根据此过程提高此文件的效率/大小？

PS我知道“粘贴”方法可能只是添加格式而不是值，然后我尝试添加.PasteSpecial xlPasteValues而不是粘贴，但它最终抛出了我无法识别的错误

更新：

基于此解决方案，这是我尝试的新版本：

Stock 0001
    Set wbSource = xlApp.Workbooks.Open(pathSource & "Stoc 0001.xls")
    lastRow = wbSource.Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    wbTarget.Sheets("Stock 0001").Cells.Clear
    wbSource.Sheets(1).Range("A1:C" & lastRow).Copy Destination:=wbTarget.Sheets("Stock 0001").Range("A1")
    wbSource.Clo

该行wbSource.Sheets(1).Range("A1:C" & lastRow).Copy Destination:=wbTarget.Sheets("Stock 0001").Range("A1"引发“范围类的复制方法失败错误。

标签： excelvba

解决方案

而不是这个

'Stock 0001
Set wbSource = xlApp.Workbooks.Open(pathSource & "Stoc 0001.xls")
wbSource.Sheets(1).UsedRange.Copy
wbSource.Close
Set target = wbTarget.Sheets("Stock 0001")
target.UsedRange.Clear
Range("A1").Select
target.Paste

试试这个

wbSource.Sheets(1).Columns("").Copy Destination:=wbTarget.Sheets("Stock 0001").Range("A1")

在我放置的地方Columns，只需将其替换为您正在使用的任何范围，Range()等等Cells复制和粘贴需要一段时间，如果您已经在另一个位置复制某些内容，则会出现问题。这只是为您获取数据

此外，这段代码将是你永远的朋友

With Sheets("Sheet1")
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With

这将找到 A 列的底行（或您的“始终填充”列将是

Sub LastRow()

    Dim wb As Workbook, ws As Worksheet, LastRow As Long

    Set wb = ThisWorkbook
    Set ws = Worksheets("Data")

    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    With ws.Range(ws.Cells(2, 13), ws.Cells(LastRow, 13))
        'This is Range M2:M(bottom)
        .
        .
        'etc
        .
    End With

End Sub

编辑....3：

Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False
Application.CutCopyMode = False

'Stock 0001
Set wbSource = xlApp.Workbooks.Open(pathSource & "Stock 0001.xls")

而不是所有这些，请使用

Set wbSource = Workbooks.Open(pathSource & "Stock 0001.xls")

推荐阅读