Question

我得到了一个很好的vba代码来从其他已关闭的工作簿中提取数据（数据结构和名称将始终保持相同）

代码实际上允许用户选择一个正确的工作簿，代码将完成剩下的工作，将相关数据复制到用户当前正在使用的工作簿上。

我知道它的工作方式是......不优雅，并且肯定有更好的方法来做到这一点，但我确信工作簿的结构不会很快改变，如果他们这样做我试图确保代码尽可能简单，易于维护。

我正在使用模块，因为通过工作簿，用户将重复执行相同的操作4次。该模块有三个参数，它应该寻找的工作表（将保持不变），importRange（我应该采取的列，工作簿中的表或范围中的40多列，我需要4-6列。像我一样说，数据结构将保持不变）和destinRange（目标范围，代码将导入数据复制到的范围）。

以下是当用户点击工作表中的按钮时我给模块的参数示例：

Dim currentWorkSheet As String
Dim importRange As String
Dim desinRange As String

currentWorkSheet = "Summary"
importRange = "Summary!C2:C500000,Summary!F2:F500000,Summary!G2:G500000,Summary!I2:I500000,Summary!W2:W500000"
desinRange = "A2:E500000"

ImportarInfo currentWorkSheet, importRange, desinRange

由于某种原因，我无法理解，在代码将数据粘贴到目标范围后，Excel始终会冻结。我尝试过改变一些事情，但我不能解决这个问题。

Sub ImportarInfo(Worksheet As String, importRange As String, DestinRange As String)
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel 2007-16", "*.xlsx; *.xlsm; *.xlsa; *.xlsb"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            Workbooks.Open .SelectedItems(1)
            Set wkbSourceBook = ActiveWorkbook
            Sheets("Sheet2").Range("K1") = Application.ActiveWorkbook.FullName
            Worksheets(Worksheet).Activate
            If Worksheet = "TTS_DETAIL" Then
                ConvertTableToRange
                On Error GoTo Help
                wkbSourceBook.Sheets(Worksheet).Rows("1:2").Delete
                ActiveSheet.Range("A:AQ").AutoFilter Field:=27, Criteria1:=Array( _
                "02", "23", "30", "33"), Operator:=xlFilterValues
            Else
                If Worksheet = "AVYXSummary" Then
                    ActiveSheet.Range("A:W").AutoFilter Field:=3, Criteria1:="<=700" _
                    , Operator:=xlAnd
                End If
            End If
            Set rngSourceRange = Application.InputBox(prompt:="Select source range", Title:="Source Range", Default:=importRange, Type:=8)
            wkbCrntWorkBook.Activate
            Set rngDestination = Application.InputBox(prompt:="Select destination cell", Title:="Select destination", Default:=DestinRange, Type:=8)
            rngSourceRange.Copy rngDestination
            rngDestination.CurrentRegion.EntireColumn.AutoFit
            wkbSourceBook.Close savechanges:=False
        End If
    End With
End Sub

我做了我的研究但是我找不到类似于我的问题，因为有人对vba代码有问题，其目标是完成与我类似的事情。

代码导入大约5k-8k记录

我的VBA脚本崩溃太多了

0 个答案: