Question

我试图通过浏览我的计算机在excel文件（2）中拉出文件 - （1）。并随机从文件 - （1）中提取不同单元格中的数据并将其粘贴到文件（2）中我是初学者，并试图从不同的程序中复制位和部分，使其工作。我已经编写了一个工作正常的代码。

我遇到了一些问题。 a）当我一个接一个地复制和粘贴每个单元时，程序太长而且我的屏幕闪烁白色很多次。（我尝试过Application.EnableEvents = False，但它没有用。可能我不知道在哪里插入它）

b）一旦我从文件中复制数据就可以完成（1）在文件（2）内，文件（1）可以关闭（或从浏览链接中松开）。

c）代码可以缩短吗？（比如一起复制和粘贴等）。我必须从另外10个单元格中复制数据。

Sub PullData()
Dim uploadfile As Variant
Dim uploader As Workbook
Dim CurrentBook As Workbook

Set CurrentBook = ActiveWorkbook
MsgBox ("Please select uploader file to be reviewed")
uploadfile = Application.GetOpenFilename()
If uploadfile = "False" Then
    Exit Sub
End If

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("L10").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO29").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("L11").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO26").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("H24").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO13").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("H27").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO18").PasteSpecial Paste:=xlPasteValues


Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("H26").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO17").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("L9").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO25").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("E42").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO34").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("E43").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO33").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("E48").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO45").PasteSpecial Paste:=xlPasteValues

Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("E50").Copy
End With
CurrentBook.Activate
Sheets("Calculations").Range("AO44").PasteSpecial Paste:=xlPasteValues

End Sub

Answer 1

这对你有很大的帮助：

Sub PullData()

Dim uploadfile As Variant
Dim uploader As Workbook
Dim CurrentBook As Workbook

Application.ScreenUpdating = False

Set CurrentBook = ThisWorkbook 'refers to workbook with code

MsgBox ("Please select uploader file to be reviewed")

uploadfile = Application.GetOpenFilename()

If uploadfile = "False" Then Exit Sub

Set uploader = Workbooks.Open(uploadfile) 'stay away from ActiveWorkbook AMAP

With CurrentBook.Sheets("Calculations")
    .Range("AO29").Value = uploader.Sheets(1).Range("L10").Value
    .Range("AO26").Value = uploader.Sheets(1).Range("L11").Value
    .Range("AO13").Value = uploader.Sheets(1).Range("H24").Value
    'add the rest of your references here
End With 

uploader.close savechanges:=false

End Sub

Answer 2

以下是您正在进行的操作的简化版本，实际上每次都会选择随机单元格。

Sub PullData()

Dim lngCount As Long
Dim lngRow As Long
Dim lngSrcRow As Long
Dim lngSrcCol As Long

Dim uploadfile As Variant
Dim uploader As Workbook
Dim CurrentBook As Workbook

Set CurrentBook = ActiveWorkbook
MsgBox ("Please select uploader file to be reviewed")
uploadfile = Application.GetOpenFilename()
If uploadfile = "False" Then
    Exit Sub
End If

Application.ScreenUpdating = False

Set uploader = Workbooks.Open uploadfile
For lngCount = 1 To 10
    Do While True
        lngRow = Abs(lngRow + Application.WorksheetFunction.RandBetween(-5, 10))
        If lngRow = 0 Then lngRow = lngRow + 1
        If IsEmpty(CurrentBook.Sheets("Sheet1").Range("A" & lngRow)) Then Exit Do
    Loop
    lngSrcRow = Application.WorksheetFunction.RandBetween(1, ActiveSheet.UsedRange.Rows.Count)
    lngSrcCol = Application.WorksheetFunction.RandBetween(1, ActiveSheet.UsedRange.Columns.Count)
    CurrentBook.Worksheets("Calculations").Range("AO" & lngRow).Value = ActiveSheet.Cells(lngSrcRow, lngSrcCol).Value
Next lngCount

Application.ScreenUpdating = True
Application.CutCopyMode = False
uploader.close savechanges:=false
End Sub

从一个文件中随机复制数据，并使用宏

2 个答案: