[英]VBA: copy and paste by specific text in a cell
一个善良的灵魂为我提出的另一个问题制作了这个代码。 但我正在考虑复制 sheet1 中的单元格,其中包含特定文本,然后将其粘贴到 sheet2 中。
所以我在 sheet1 中有一个数据输入,数据输入中的每一列都有一些标题,我想按特定的 header 名称排序,复制它们,然后粘贴 header 与我的关键字匹配的两行列,在 sheet2 . 将数据粘贴到 sheet2 中,应该在前两行可用,就像在我的代码中一样。 真的想像现在一样保留大部分代码,然后可能只更改我在特定范围内复制两行的子代码。 将不胜感激帮助:)
Option Explicit
Sub call_copy_sub_ranges()
Dim ws1 As Worksheet, wsOut As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Ark1")
Set wsOut = ThisWorkbook.Worksheets("Ark2")
Dim ar
ar = Array("HeaderA", "HeaderB", "HeaderC", "HeaderD", "HeaderE", _
"HeaderF", "HeaderG", "HeaderH", "HeaderI", "HeaderJ", "HeaderK", _
"HeaderL", "HeaderM", "HeaderN", "HeaderO", "HeaderP", "HeaderQ", _
"HeaderR", "HeaderS", "HeaderT", "HeaderU", "HeaderV", "HeaderW", _
"HeaderX", "HeaderY", "HeaderZ", "HeaderAA", "HeaderAB", "HeaderAC", _
"HeaderAD", "HeaderAE", "HeaderAF", "HeaderAG", "HeaderAH", "HeaderAI", _
"HeaderAJ", "HeaderAK", "HeaderAL", "HeaderAM", "HeaderAN", "HeaderAO", _
"HeaderAP", "HeaderAQ", "HeaderAR", "HeaderAS", "HeaderAT", "HeaderAU", _
"HeaderAV", "HeaderAW", "HeaderAX", "HeaderAY")
wsOut.Range("A1:AY1").Value = ar
copy_sub_ranges ws1, wsOut
MsgBox "Done"
End Sub
Sub copy_sub_ranges(ByVal ws1 As Worksheet, ByVal wsOut As Worksheet)
Dim rng As Range, rngOut As Range, ar, s
ar = Array("S2:S3", "BF7:BH8", "BI9:CC10", _
"CD9:CQ9", "CR9:CS10", "CT9:CV9", "CW9:CW10", "CX10", "EE9:EI10")
' target
Set rngOut = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
If Not IsEmpty(wsOut.Range("A1").Text) Then
Set rngOut = rngOut.offset(1, 0)
End If
For Each s In ar
Set rng = ws1.Range(s)
Debug.Print rng.Address, rngOut.Address
rng.Copy rngOut
Set rngOut = rngOut.offset(0, rng.Columns.Count)
Next
' underline
Set rng = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
With rng.Resize(1, rngOut.Column - 1).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlMedium
End With
End Sub
这将 Ark2 上的 row1 中的文本与 Ark1 上的 row1 中的文本匹配,并相应地复制行 2:3。
Option Explicit
Sub call_copy_cols()
Dim ws1 As Worksheet, wsOut As Worksheet
Dim dict As Object, k As Variant
Set dict = CreateObject("Scripting.Dictionary")
Dim rngSearch As Range, rngFound As Range, rngOut As Range
Dim iLastCol As Long, i As Long, s As String, iLastRow As Long
Dim colSource As Long, colTarget As Long
Set ws1 = ThisWorkbook.Worksheets("Ark1")
Set wsOut = ThisWorkbook.Worksheets("Ark2")
' Get List of header text on Output Sheet to search for
'iLastCol = wsOut.Cells(1, Columns.Count).End(xlToLeft).Column
'For i = 1 To iLastCol
' s = Trim(wsOut.Cells(1, i))
' If Len(s) > 0 Then
' dict.Add s, i
' 'Debug.Print s, i
' End If
'Next
' specify headers
dict.Add "Header1", 1
dict.Add "Header2", 2
dict.Add "Header3", 3
For Each k In dict.keys
wsOut.Cells(1, dict(k)) = k
Next
' ws1 header range
iLastCol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Set rngSearch = ws1.Range("A1").Resize(1, iLastCol)
'Debug.Print rngSearch.Address
' output range
iLastRow = wsOut.UsedRange.Rows.Count
Set rngOut = wsOut.Cells(iLastRow + 1, 1)
' copy each column
For Each k In dict.keys
Set rngFound = rngSearch.Find(k)
If rngFound Is Nothing Then
MsgBox "'" & k & "' Not found in headers", vbCritical
Exit Sub
Else
'copy to output
colSource = rngFound.Column
colTarget = dict(k)
ws1.Range("A2:A3").Offset(0, colSource - 1).Copy rngOut.Offset(0, colTarget - 1)
'Debug.Print k, colSource, colTarget
End If
Next
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.