Excel VBA 文字抽出について 下記のようなプログラムを作成しました sub sumple5(

Excel VBA 文字抽出について
下記のようなプログラムを作成しました
sub sumple5()
Dim cnt As Long,lastcol As Long,Ws As Worksheets
Dim myFound As Range,my First As Range
Set Ws=worksheets("結果")
cnt=12
With Worksheets("情報")
lastcol=.cells(3,Columns.Count).End(xlToLeft).Column
Set myFound=.Range("A:A").Find(what:=Ws.Range("E4"),LookIn:=xlValues,lookat:=xlwhole)
If Not myFound Is Nothing Then
set myFirst=myFound
GoTo 処理
Do
Set myFound=.Range("A:A").FindNext(after:=myFound)
If myFound.Address=myFirst.Address Then Exit Do
GoTo 処理
処理：cnt=cnt+1
Ws.Cells(cnt,"B").Resize(,lastcol-1).value=myFound.offset(0,1).Resize(,lastcol-1).value
loop
Else
End IF
End With
End sub
このプログラムを下記条件に変更したいのですがアドバイスお願いいたします
①検索一致したセルより右側のセルをすべて抽出するを一致より右側１４箇所目までを抽出する
例　A3一致の場合O3までを抽出する
②抽出したセル縦に抽出を行う仕様にしたい
以上　よろしくお願いいたします

No.1 ベストアンサー 回答者： fujillin 回答日時： 2017/07/04 13:23

こんにちは

＞下記のようなプログラムを作成しました
＞下記条件に変更したいのですが～
作成したのなら、修正もたやすいのではと思いますが？？

とはいえ、ご提示のコードをそのままコピペしてもエラーで動作しないようです。
また、GoToでループの中に飛び込むのもいかがなものかと思いますが…
（拒否られるかと思いきや、動作してしまうようですが）

＞②抽出したセル縦に抽出を行う仕様にしたい
意味が良くわかりませんが、『元の行のデータを列データに変えてコピーしたい』という意味と解釈しました。

Sub Sample()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tmpR As Range, fnd As Range
Dim fAddress As String

Const col = 14 ' コピー対象セル数
Set sh1 = Worksheets("情報") ' 抽出元シート
Set sh2 = Worksheets("結果") ' 抽出先シート
Set tmpR = sh2.Range("B12").Resize(col)

With sh1.Range("A:A")
　Set fnd = .Find(what:=sh2.Range("E4"), LookIn:=xlValues, lookat:=xlWhole)
　If Not fnd Is Nothing Then
　　fAddress = fnd.Address
　　Do
　　　fnd.Offset(, 1).Resize(, col).Copy
　　　tmpR.PasteSpecial Paste:=xlPasteValues, Transpose:=True
　　　Set tmpR = tmpR.Offset(, 1)
　　　Set fnd = .FindNext(fnd)
　　Loop While Not fnd Is Nothing And fnd.Address <> fAddress
　End If
End With

End Sub