[英]VBA: copy and paste by specific text in a cell
a kind soul made me this code for another question i asked.一个善良的灵魂为我提出的另一个问题制作了这个代码。 But im thinking about copying cells in sheet1, with specific text in it, and then pasting it in sheet2.
但我正在考虑复制 sheet1 中的单元格,其中包含特定文本,然后将其粘贴到 sheet2 中。
So i got a data input in sheet1, there is some headers for each column in the data input, and i want to sort by specific header names, copy them, and paste the two rows of the columns which header matches my keywords, in sheet2.所以我在 sheet1 中有一个数据输入,数据输入中的每一列都有一些标题,我想按特定的 header 名称排序,复制它们,然后粘贴 header 与我的关键字匹配的两行列,在 sheet2 . Pasting the data in sheet2, should be at the first two lines available, like here in my code already.
将数据粘贴到 sheet2 中,应该在前两行可用,就像在我的代码中一样。 Really want to keep most of the code like it is now, and then maybe only change the sub where i copy the two rows in a specific range.
真的想像现在一样保留大部分代码,然后可能只更改我在特定范围内复制两行的子代码。 Would appreciate the help:)
将不胜感激帮助:)
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
This matched the text in row1 on Ark2 with the text in row1 on Ark1 and copies rows 2:3 accordingly.这将 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.