从另一个工作簿选择工作表获取数据的代码
从另一个工作簿选择工作表获取数据的代码
提问于 2018-10-17 02:43:02
我需要从多个工作簿和多个工作表中复制和粘贴数据。(名称保持工作表和工作簿的更改)
我有一个代码，但这里我需要手动选择单元格。我只想选择工作表，它会自动将工作表中的整个数据导入到我的工作簿中的指定工作表。这有可能吗？
Sub ImportDatafromotherworksheet()
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-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Workbooks.Open .SelectedItems(1)
Set wkbSourceBook = ActiveWorkbook
Set rngSourceRange = Application.InputBox(prompt:="Select source range", Title:="Source Range", Default:="A1", Type:=8)
wkbCrntWorkBook.Activate
Set rngDestination = Application.InputBox(prompt:="Select destination cell", Title:="Select Destination", Default:="A1", Type:=8)
rngSourceRange.Copy rngDestination
rngDestination.CurrentRegion.EntireColumn.AutoFit
wkbSourceBook.Close False
End If
End With
End Sub回答 2
Stack Overflow用户
回答已采纳
发布于 2018-10-17 14:50:44
您可以使用“Parent”range获取其源工作表UsedRange，如下所示：
Sub ImportDatafromotherworksheet()
Dim wkbCrntWorkBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
With Workbooks.Open(.SelectedItems(1)) ' open and reference current selected "source" workbook
Set rngSourceRange = Application.InputBox(prompt:="Select any cell in the wanted sheet ", Title:="Source sheet chosing", Default:="A1", Type:=8) ' have user select any cell in source sheet
If Not rngSourceRange Is Nothing Then ' if any valid "source" range selected
wkbCrntWorkBook.Activate ' this could be omitted since subsequent InputBox allowa user to switch between open workbooks
Set rngDestination = Application.InputBox(prompt:="Select destination cell", Title:="Select Destination", Default:="A1", Type:=8) ' have user select "destination" cell
If Not rngDestination Is Nothing Then ' if any valid "destination" range selected
rngSourceRange.Parent.UsedRange.Copy rngDestination.Cells(1, 1) ' be sure to collapse "destination" range to a single cell
rngDestination.CurrentRegion.EntireColumn.AutoFit
End If
End If
.Close False ' close referenced (i.e. current "source" sheet) sheet
End With
End If
End With
End SubStack Overflow用户
发布于 2018-10-17 03:16:34
这里有一个简单的例子，你可以从一个复制到另一个。如果你需要更具体的帮助，请告诉我。
Sub testing()
Dim des_wb As Workbook, sou_wb As Workbook
Dim des_ws As Worksheet
Dim sou_rng As Range
ChDir (ActiveWorkbook.Path)
Set des_wb = ActiveWorkbook
Set sou_wb = Workbooks.Open(Application.GetOpenFilename)
Set sou_ws = sou_wb.Worksheets(1)
Set sou_rng = sou_ws.Range("A1").CurrentRegion
sou_rng.Copy
des_wb.Worksheets(1).Range("A1").PasteSpecial
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/52842048
复制相关文章
相似问题