时间戳

首页 > 解决方案 > Excel VBA：单列：在下面查找文本，复制文本和其他行的文本，在第二个选项卡上转置为列

excel - Excel VBA：单列：在下面查找文本，复制文本和其他行的文本，在第二个选项卡上转置为列

问题描述

我有一个非常具体的 VBA 需求：从单列数据创建数据表。

在列中查找文本，复制/粘贴，然后向下删除 x 行，复制/粘贴，然后向下删除 x 行，复制/粘贴等。我有一列数据 A:A

然后循环查找下一个“MyText”并粘贴到 A3 中，依此类推。

谢谢！查理·E

标签： excelvba

解决方案

请尝试下一个代码：

Sub CopyMyTextReferences()
  Dim sh As Worksheet, sh2 As Worksheet, i As Long, MyText As String, rngTxt As Range
  Dim rng As Range, rng2 As Range, lastRow As Long, lastR As Long, strFirstAddr As String
  
  Set sh = ActiveSheet           'use here your sheet to copy from
  Set sh2 = Worksheets("Sheet2") 'use here your sheet where to copy
  MyText = "testStr" 'use here your string to be searched
  
  lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
  Set rng = sh.Range("A2:A" & lastRow)
  
  Set rngTxt = rng.Find(MyText, sh.Range("A2"), xlValues, xlWhole)
  If Not rngTxt Is Nothing Then
     strFirstAddr = rngTxt.Address
     
     Do
        lastR = sh2.Range("A" & Rows.count).End(xlUp).Row + 1
        Set rng2 = sh2.Range("A" & lastR)
        With rng2
          .Value = rngTxt.Offset(4).Value
          .Offset(1).Value = rngTxt.Offset(5).Value
          .Offset(2).Value = rngTxt.Offset(8).Value
          .Offset(3).Value = rngTxt.Offset(16).Value
          '.Offset(4).Value = rngTxt.Offset(xx).Value
        End With
        Set rngTxt = rng.FindNext(After:=rngTxt)
     Loop Until rngTxt.Address = strFirstAddr
  Else
     MsgBox MyText & " could not be found...": Exit Sub
  End If
End Sub

推荐阅读