[英]Copying a row, inserting multiple new rows with the pasted info on multiple sheets Excel VBA
[英]VBA - Copying from A2:AA2 in multiple excel sheets to be pasted in one sheet, or to be pasted below current sheet
我有下面的代码,可以完美地打开一个文件,选择 1 个文件,它会自动从 A2:AA2 复制并粘贴到我的主数据表下(在我的当前数据下方)。 我想添加一个功能,我可以 select 多张纸,它将从 A2:AA2 复制到所有选定的 excel 张(最多 30 张)中,然后合并成一张纸(我可以稍后粘贴); 或者全部粘贴在我的主表中。
谢谢
Sub add_data()
Dim openfile As String
Dim OpenBook As Workbook
Dim targetworkbook As String, targetsheetname As String
Application.ScreenUpdating = False
targetworkbook = Application.GetOpenFilename(FileFilter:="Excel Files, *.xls*", _
Title:="Select Data", MultiSelect:=True)
If targetworkbook = "False" Or openfile = "" Then
'If the value is false or null then exit
Set OpenBook = Application.Workbooks.Open(targetworkbook)
OpenBook.Sheets(1).Select
Range("A2:AA2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ThisWorkbook.Worksheets("xxx").Range("A4").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
OpenBook.Close False
End If
Application.ScreenUpdating = True
End Sub
这是一段代码,允许您选择从工作簿中复制数据的工作表:
Sub add_data()
Dim OpenBook As Workbook
Dim targetworkbook As String
Dim wsh As Worksheet
Dim coll As New Collection
Dim selected_sheets As Variant
Dim sheets_() As String
Dim j As Integer
Dim elt
Application.ScreenUpdating = False
targetworkbook = Application.GetOpenFilename(FileFilter:="Excel Files, *.xls*", _
Title:="Select Workbook to open", MultiSelect:=False)
If targetworkbook <> "False" And targetworkbook <> "Faux" Then
Set OpenBook = Workbooks.Open(targetworkbook, , True)
For Each wsh In OpenBook.Worksheets
coll.Add wsh.Name
Next wsh
j = 1
ReDim sheets_(1 To coll.count)
For Each elt In coll
sheets_(j) = elt
j = j + 1
Next elt
selected_sheets = Split(InputBox("Here are the sheets availables: " & vbNewLine & Join(sheets_, ", ") & vbNewLine & "Please enter the sheets you want to select, separated by a comma", "Please select sheets to copy from", ""), ",")
For Each wsh In OpenBook.Worksheets
For Each elt In selected_sheets
If wsh.Name = Trim(CStr(elt)) Then
With wsh
.Activate
.Range("A2:AA2").Select
.Range(Selection, Selection.End(xlDown)).Copy
End With
ThisWorkbook.Worksheets("xxx").Range("A4").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next elt
Next wsh
OpenBook.Close False
End If
Application.ScreenUpdating = True
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.