Copy/Paste 列
Copy/Paste columns
我在一个 excel 工作簿中有几个包含 header 的列，我想将其中一些列复制到另一个工作簿中。
假设我有我的原始工作簿：
Ident|Name|Code|Part|Desc|U|Total
这些是列的 header，下面有一些数据。
我只想复制另一个工作簿中的 Ident、Code 和 Part 列中的数据，该工作簿具有相同的 header，但顺序不同，但其中一个 header 具有不同的名称：
Code|Ident|Piece
为空白，Piece对应Part。
所以我想要一个从原始工作簿获取数据并将其复制到目标工作簿的代码。另外，如果可能的话，我希望您可以从文件中选择原始工作簿，因为我有不同的 excel 文件可供选择。
感谢您的回答。我从来没有用过VBA，我正在努力学习。
我有下面的代码，可以让你手动选择你想要的数据，但我想要类似的东西，在识别 headers 后自动选择。
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
我在这里添加我修改的部分：
arrC = Split("CODE|ident|Piece", "|")
lastColO = shO.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).Value
'Copy the columns:
arrC = Split("CODE|ident|Piece", "|")
lastColO = shO.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).Value
'Copy the columns:
For j = 0 To UBound(arrC)
If arrC(j) = "Ident" Then strH = "ident" Else strH = arrC(j)
If arrC(j) = "Code" Then strH = "CODE" Else strH = arrC(j)
If arrC(j) = "Piece" Then strH = "Part" Else strH = arrC(j)
For i = 1 To UBound(arrO, 2)
If arrO(1, i) = strH Then
lastRowO = shO.Cells(Rows.Count, i).End(xlUp).Row 'last row of the found orig header column
lastRowC = shC.Cells(Rows.Count, j + 1).End(xlUp).Row 'last row of toCopy sheet header column
arrTransf = shO.Range(shO.Cells(2, i), shO.Cells(lastRowO, i)).Value
Set copyCell = shC.Range(shC.Range("A1"), shC.Cells(1, lastColO)).Find(arrC(j))
If copyCell Is Nothing Then MsgBox "There is not a column named """ & _
arrC(j) & """ in the page to Copy.": Exit Sub
copyCell.Offset(1, 0).Resize(UBound(arrTransf, 1), UBound(arrTransf, 2)).Value = arrTransf
End If
Next i
Next j
End Sub
请试试这个代码。它将列从活动 sheet 复制到 shC worksheet，必须在下面的代码中设置：
Sub moveColumnsContent()
Dim shO As Worksheet, shC As Worksheet, lastRowO As Long, lastRowC As Long
Dim arrO As Variant, arrC As Variant, lastColO As Long, lastColC As Long
Dim El As Variant, arrTransf As Variant, strH As String, copyCell As Range
Dim wbNumb As Variant, wb As Workbook, ws As Worksheet, strWB As String
Dim WbC As Workbook, sh As Worksheet, strWh As String, shNunb As String
Dim i As Long, j As Long
Set shC = ActiveSheet
WbSelection:
For i = 1 To Workbooks.count
strWB = strWB & Workbooks(i).Name & " - " & i & vbCrLf
Next i
wbNumb = InputBox("Please, write the the right workbook name number to be chosen:" & vbCrLf & _
vbCrLf & strWB, "Choose the workbook from where to copy columns!", 1)
If wbNumb = "" Then MsgBox "You did not select anything and code stops!"
Exit Sub
If IsNumeric(wbNumb) Then
On Error Resume Next
Set WbC = Workbooks(CLng(wbNumb))
if Err.Number<> 0 Then
Err.Clear: On Error GoTo 0:Exit Sub
End If
On Error GoTo 0
Else
MsgBox "Please select the number to the right side of the chosen workbook!": GoTo WbSelection
End If
WsSelection:
For i = 1 To WbC.Worksheets.count
strWh = strWh & WbC.Worksheets(i).Name & " - " & i & vbCrLf
Next
shNunb = InputBox("Please, write the the right sheet name number to be chosen:" & vbCrLf & _
vbCrLf & strWh, "Select the worksheet to be used for copying the columns!", 1)
If shNunb = "" Then MsgBox "Please select a worksheet number to be selected for copying columns!": _
GoTo WsSelection
Set shO = WbC.Worksheets(CLng(shNunb))
arrC = Split("Code|Ident|Piece", "|")
lastColO = shO.Cells(1, Cells.Columns.count).End(xlToLeft).Column
arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).value
'Copy the columns:
For j = 0 To UBound(arrC)
If arrC(j) = "Piece" Then strH = "Part" Else strH = arrC(j)
For i = 1 To UBound(arrO, 2)
If arrO(1, i) = strH Then
lastRowO = shO.Cells(Rows.count, i).End(xlUp).Row 'last row of the found orig header column
lastRowC = shC.Cells(Rows.count, j + 1).End(xlUp).Row 'last row of toCopy sheet header column
arrTransf = shO.Range(shO.Cells(2, i), shO.Cells(lastRowO, i)).value
Set copyCell = shC.Range(shC.Range("A1"), shC.Cells(1, lastColO)).Find(arrC(j))
If copyCell Is Nothing Then MsgBox "There is not a column named """ & _
arrC(j) & """ in the page to Copy.": Exit Sub
copyCell.Offset(1, 0).Resize(UBound(arrTransf, 1), UBound(arrTransf, 2)).value = arrTransf
End If
Next i
Next j
End Sub
如果您需要在 sheet 中复制更多 headers，将它们添加到 "Code|Ident|Piece" 字符串中就足够了。
现在，想想如何更方便地使用它，可能更好的方法是命名 sheet 以特定方式复制列的位置（也许 "MasterSheet") 并将列复制到活动列。或者，在所有工作簿 sheet 之间迭代并自动执行此过程。但是，请按原样尝试代码，让我知道如何看起来更方便。
这应该可行，您只需要调整目标 sheet，如果是这种情况，请添加更多 origin/target 具有不同列名称的情况：
Option Explicit
Sub Main()
Dim arrOrigin As Variant: arrOrigin = GetArrayFromSheet
Dim OriginHeaders As New Dictionary: Set OriginHeaders = GetOriginHeaders(arrOrigin)
With ThisWorkbook.Sheets("Your target sheet name") 'change this name
Dim arrTarget As Variant: ReDim arrTarget(1 To UBound(arrOrigin), _
1 To .UsedRange.Columns.Count)
'Last row on column 1 (or column A)
Dim LastRow As Long: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
Dim TargetHeaders As New Dictionary: Set TargetHeaders = GetTargetHeaders(arrTarget)
Dim i As Long
Dim Key As Variant
Dim OriginColumn As Long, TargetColumn As Long
Dim x As Long: x = 1
For i = 2 To UBound(arrOrigin)
For Each Key In TargetHeaders.Keys
OriginColumn = OriginHeaders(Split(TargetHeaders(Key), "\")(0))
TargetColumn = Split(TargetHeaders(Key), "\")(1)
arrTarget(x, TargetColumn) = arrOrigin(i, OriginColumn)
Next Key
Next i
ThisWorkbook.Sheets("Your target sheet name").Range("A" & LastRow).Resize(UBound(arrTarget), UBound(arrTarget, 2)).Value = arrTarget
End Sub
Private Function GetArrayFromSheet() As Variant
Dim wb As Workbook: Set wb = FilePicker
Dim ws As Worksheet
For Each ws In wb.Sheets
If ws.Name Like "* Annex 1" Then
GetArrayFromSheet = ws.UsedRange.Value
wb.Close False
Exit Function
End If
Next ws
End Function
Private Function FilePicker() As Workbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Set FilePicker = Workbooks.Open(.SelectedItems(1))
Else
MsgBox "No file was selected, the procedure will end"
End
End If
End With
End Function
Private Function GetOriginHeaders(arr As Variant) As Dictionary
Set GetOriginHeaders = New Dictionary
Dim i As Long
For i = 1 To UBound(arr, 2)
GetOriginHeaders.Add arr(1, i), i
Next i
End Function
Private Function GetTargetHeaders(arr As Variant) As Dictionary
Set GetOriginHeaders = New Dictionary
Dim i As Long
Dim MyHeader As String
For i = 1 To UBound(arr, 2)
MyHeader = arr(1, i)
Select Case MyHeader
Case "Piece"
MyHeader = "Part"
'..More cases for different names
End Select
TargetHeaders.Add arr(1, i), MyHeader & "\" & i
Next i
End Function
如果您打算以固定顺序提取三列集，将它们复制到第一个三列目标列 A:C，您可以尝试以下 Rearrange 过程执行这些步骤：
[0-1]获取源数据[2 ] 通过 一行 按给定顺序重新排列源数据的列，而不是每次都复制单独的列数组 [3 ] 将（重新排列的）数据写入目标 sheet
Sub Rearrange(src As Worksheet, tgt As Worksheet)
'Purpose: extract and rearrange data array columns
'Author: https://whosebug.com/users/6460297/t-m
With src
'[0] get last row of source data in column A:A (Ident)
Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'[1] assign data to (1-based) 2-dim variant datafield array
Dim data: data = .Range("A2:G" & lastRow)
'[2] rearrange columns
' where Array(3,1,4) gets the 3rd, 1st and 4th column only
' (and Evaluate("ROW(1:nnn)") gets the entire row set)
data = Application.Index(data, Evaluate("ROW(1:" & (lastRow - 1) & ")"), Array(3, 1, 4))
End With
'[3] write (rearranged) data to target sheet
tgt.Range("A2").Resize(UBound(data), 3) = data
End Sub
但是，如果您遇到可变的目标列结构，您可以使用 并根据您的需要进行更改:-)
我在一个 excel 工作簿中有几个包含 header 的列，我想将其中一些列复制到另一个工作簿中。
假设我有我的原始工作簿：
Ident|Name|Code|Part|Desc|U|Total
这些是列的 header，下面有一些数据。
我只想复制另一个工作簿中的 Ident、Code 和 Part 列中的数据，该工作簿具有相同的 header，但顺序不同，但其中一个 header 具有不同的名称：
Code|Ident|Piece
为空白，Piece对应Part。 所以我想要一个从原始工作簿获取数据并将其复制到目标工作簿的代码。另外，如果可能的话，我希望您可以从文件中选择原始工作簿，因为我有不同的 excel 文件可供选择。
感谢您的回答。我从来没有用过VBA，我正在努力学习。
我有下面的代码，可以让你手动选择你想要的数据，但我想要类似的东西，在识别 headers 后自动选择。
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
我在这里添加我修改的部分：
arrC = Split("CODE|ident|Piece", "|")
lastColO = shO.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).Value
'Copy the columns:
arrC = Split("CODE|ident|Piece", "|")
lastColO = shO.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).Value
'Copy the columns:
For j = 0 To UBound(arrC)
If arrC(j) = "Ident" Then strH = "ident" Else strH = arrC(j)
If arrC(j) = "Code" Then strH = "CODE" Else strH = arrC(j)
If arrC(j) = "Piece" Then strH = "Part" Else strH = arrC(j)
For i = 1 To UBound(arrO, 2)
If arrO(1, i) = strH Then
lastRowO = shO.Cells(Rows.Count, i).End(xlUp).Row 'last row of the found orig header column
lastRowC = shC.Cells(Rows.Count, j + 1).End(xlUp).Row 'last row of toCopy sheet header column
arrTransf = shO.Range(shO.Cells(2, i), shO.Cells(lastRowO, i)).Value
Set copyCell = shC.Range(shC.Range("A1"), shC.Cells(1, lastColO)).Find(arrC(j))
If copyCell Is Nothing Then MsgBox "There is not a column named """ & _
arrC(j) & """ in the page to Copy.": Exit Sub
copyCell.Offset(1, 0).Resize(UBound(arrTransf, 1), UBound(arrTransf, 2)).Value = arrTransf
End If
Next i
Next j
End Sub
请试试这个代码。它将列从活动 sheet 复制到 shC worksheet，必须在下面的代码中设置：
Sub moveColumnsContent()
Dim shO As Worksheet, shC As Worksheet, lastRowO As Long, lastRowC As Long
Dim arrO As Variant, arrC As Variant, lastColO As Long, lastColC As Long
Dim El As Variant, arrTransf As Variant, strH As String, copyCell As Range
Dim wbNumb As Variant, wb As Workbook, ws As Worksheet, strWB As String
Dim WbC As Workbook, sh As Worksheet, strWh As String, shNunb As String
Dim i As Long, j As Long
Set shC = ActiveSheet
WbSelection:
For i = 1 To Workbooks.count
strWB = strWB & Workbooks(i).Name & " - " & i & vbCrLf
Next i
wbNumb = InputBox("Please, write the the right workbook name number to be chosen:" & vbCrLf & _
vbCrLf & strWB, "Choose the workbook from where to copy columns!", 1)
If wbNumb = "" Then MsgBox "You did not select anything and code stops!"
Exit Sub
If IsNumeric(wbNumb) Then
On Error Resume Next
Set WbC = Workbooks(CLng(wbNumb))
if Err.Number<> 0 Then
Err.Clear: On Error GoTo 0:Exit Sub
End If
On Error GoTo 0
Else
MsgBox "Please select the number to the right side of the chosen workbook!": GoTo WbSelection
End If
WsSelection:
For i = 1 To WbC.Worksheets.count
strWh = strWh & WbC.Worksheets(i).Name & " - " & i & vbCrLf
Next
shNunb = InputBox("Please, write the the right sheet name number to be chosen:" & vbCrLf & _
vbCrLf & strWh, "Select the worksheet to be used for copying the columns!", 1)
If shNunb = "" Then MsgBox "Please select a worksheet number to be selected for copying columns!": _
GoTo WsSelection
Set shO = WbC.Worksheets(CLng(shNunb))
arrC = Split("Code|Ident|Piece", "|")
lastColO = shO.Cells(1, Cells.Columns.count).End(xlToLeft).Column
arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).value
'Copy the columns:
For j = 0 To UBound(arrC)
If arrC(j) = "Piece" Then strH = "Part" Else strH = arrC(j)
For i = 1 To UBound(arrO, 2)
If arrO(1, i) = strH Then
lastRowO = shO.Cells(Rows.count, i).End(xlUp).Row 'last row of the found orig header column
lastRowC = shC.Cells(Rows.count, j + 1).End(xlUp).Row 'last row of toCopy sheet header column
arrTransf = shO.Range(shO.Cells(2, i), shO.Cells(lastRowO, i)).value
Set copyCell = shC.Range(shC.Range("A1"), shC.Cells(1, lastColO)).Find(arrC(j))
If copyCell Is Nothing Then MsgBox "There is not a column named """ & _
arrC(j) & """ in the page to Copy.": Exit Sub
copyCell.Offset(1, 0).Resize(UBound(arrTransf, 1), UBound(arrTransf, 2)).value = arrTransf
End If
Next i
Next j
End Sub
如果您需要在 sheet 中复制更多 headers，将它们添加到 "Code|Ident|Piece" 字符串中就足够了。
现在，想想如何更方便地使用它，可能更好的方法是命名 sheet 以特定方式复制列的位置（也许 "MasterSheet") 并将列复制到活动列。或者，在所有工作簿 sheet 之间迭代并自动执行此过程。但是，请按原样尝试代码，让我知道如何看起来更方便。
这应该可行，您只需要调整目标 sheet，如果是这种情况，请添加更多 origin/target 具有不同列名称的情况：
Option Explicit
Sub Main()
Dim arrOrigin As Variant: arrOrigin = GetArrayFromSheet
Dim OriginHeaders As New Dictionary: Set OriginHeaders = GetOriginHeaders(arrOrigin)
With ThisWorkbook.Sheets("Your target sheet name") 'change this name
Dim arrTarget As Variant: ReDim arrTarget(1 To UBound(arrOrigin), _
1 To .UsedRange.Columns.Count)
'Last row on column 1 (or column A)
Dim LastRow As Long: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
Dim TargetHeaders As New Dictionary: Set TargetHeaders = GetTargetHeaders(arrTarget)
Dim i As Long
Dim Key As Variant
Dim OriginColumn As Long, TargetColumn As Long
Dim x As Long: x = 1
For i = 2 To UBound(arrOrigin)
For Each Key In TargetHeaders.Keys
OriginColumn = OriginHeaders(Split(TargetHeaders(Key), "\")(0))
TargetColumn = Split(TargetHeaders(Key), "\")(1)
arrTarget(x, TargetColumn) = arrOrigin(i, OriginColumn)
Next Key
Next i
ThisWorkbook.Sheets("Your target sheet name").Range("A" & LastRow).Resize(UBound(arrTarget), UBound(arrTarget, 2)).Value = arrTarget
End Sub
Private Function GetArrayFromSheet() As Variant
Dim wb As Workbook: Set wb = FilePicker
Dim ws As Worksheet
For Each ws In wb.Sheets
If ws.Name Like "* Annex 1" Then
GetArrayFromSheet = ws.UsedRange.Value
wb.Close False
Exit Function
End If
Next ws
End Function
Private Function FilePicker() As Workbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Set FilePicker = Workbooks.Open(.SelectedItems(1))
Else
MsgBox "No file was selected, the procedure will end"
End
End If
End With
End Function
Private Function GetOriginHeaders(arr As Variant) As Dictionary
Set GetOriginHeaders = New Dictionary
Dim i As Long
For i = 1 To UBound(arr, 2)
GetOriginHeaders.Add arr(1, i), i
Next i
End Function
Private Function GetTargetHeaders(arr As Variant) As Dictionary
Set GetOriginHeaders = New Dictionary
Dim i As Long
Dim MyHeader As String
For i = 1 To UBound(arr, 2)
MyHeader = arr(1, i)
Select Case MyHeader
Case "Piece"
MyHeader = "Part"
'..More cases for different names
End Select
TargetHeaders.Add arr(1, i), MyHeader & "\" & i
Next i
End Function
如果您打算以固定顺序提取三列集，将它们复制到第一个三列目标列 A:C，您可以尝试以下 Rearrange 过程执行这些步骤：
[0-1]获取源数据[2 ]通过 一行 按给定顺序重新排列源数据的列，而不是每次都复制单独的列数组[3 ]将（重新排列的）数据写入目标 sheet
Sub Rearrange(src As Worksheet, tgt As Worksheet)
'Purpose: extract and rearrange data array columns
'Author: https://whosebug.com/users/6460297/t-m
With src
'[0] get last row of source data in column A:A (Ident)
Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'[1] assign data to (1-based) 2-dim variant datafield array
Dim data: data = .Range("A2:G" & lastRow)
'[2] rearrange columns
' where Array(3,1,4) gets the 3rd, 1st and 4th column only
' (and Evaluate("ROW(1:nnn)") gets the entire row set)
data = Application.Index(data, Evaluate("ROW(1:" & (lastRow - 1) & ")"), Array(3, 1, 4))
End With
'[3] write (rearranged) data to target sheet
tgt.Range("A2").Resize(UBound(data), 3) = data
End Sub
但是，如果您遇到可变的目标列结构，您可以使用