これからの季節に親子でハイキング! >>

Sheet1にある複数行のデータを
別シート(仮にSheet2)へ2列に整形したいと思っています。

画像のようなSheet1データを、Sheet2データのようにしたいです。(実際のデータ数は1万行ほどあります。)

VBAで対応できると幸いです。
どうぞ、よろしくお願いします。

「【エクセル】複数行のデータを2列に整形(」の質問画像

このQ&Aに関連する最新のQ&A

A 回答 (3件)

こんな形でやってみました。



'--------------------------------------------------------
Option Explicit

Sub Tenki2()

'変数宣言とセット
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim r As Long, k As Long
Dim Midashi(4) As Variant, myData(4) As Variant
Dim TgtRow As Long

Set Ws1 = Worksheets(1)
Set Ws2 = Worksheets(2)

TgtRow = 2 'Sheet2の転記先は2行目から開始


'見出し行を格納
For k = 0 To 4
Midashi(k) = Ws1.Cells(1, k + 1)
Next k


Application.ScreenUpdating = False

'Sheet1のデータを上から下にループ
With Ws1
r = 2
Do While .Cells(r, 1).Value <> ""
For k = 0 To 4 'その行のデータをmyDataに格納
myData(k) = .Cells(r, k + 1)
Next k

For k = LBound(myData) To UBound(myData) 'Sheet2で、縦に転記
Ws2.Cells(TgtRow + k, 1).Value = Midashi(k)
Ws2.Cells(TgtRow + k, 2).Value = myData(k)
Next k

TgtRow = Ws2.Cells(Rows.Count, 1).End(xlUp).Row + 2 '次の転記開始行

r = r + 1

If r Mod 500 = 0 Then Application.StatusBar = r

Loop
End With

Application.StatusBar = ""
Application.ScreenUpdating = True
Ws2.Select

MsgBox "End."

End Sub
    • good
    • 0

ほとんど数式(^^;


Sub Sheet2へ転記する()
Application.ScreenUpdating = False
  Dim 最終行 As Long
  最終行 = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  Worksheets("Sheet2").Range("A:B").ClearContents
  With Worksheets("Sheet2").Range("A2:A" & 最終行 * 6 - 6)
    .FormulaR1C1 = "=IF(MOD(ROW(),6)=1,"""",INDEX(Sheet1!R1,MOD(ROW()-2,6)+1))"
   .Value = .Value
   .Offset(, 1).FormulaR1C1 = _
    "=IF(RC[-1]="""","""",INDEX(Sheet1!C[-1]:C[3],(ROW()-2)/6+2,MOD(ROW()-2,6)+1))"
    .Offset(, 1).Value = .Offset(, 1).Value
  End With
Application.ScreenUpdating = True
End Sub
    • good
    • 0

こんにちは!



一例です。
標準モジュールにしてください。

Sub Sample1()
Dim lastRow As Long, wS As Worksheet, myRng As Range
Set wS = Worksheets("Sheet1")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
With Worksheets("Sheet2")
.Range("A:B").ClearContents
Range(.Cells(2, "A"), .Cells((lastRow - 1) * 6, "A")).Formula = _
"=INDEX(Sheet1!A$1:F$1,,IF(MOD(ROW(C7),6)=0,"""",MOD(ROW(C7),6)))"
Range(.Cells(2, "B"), .Cells((lastRow - 1) * 6, "B")).Formula = _
"=INDEX(Sheet1!A:F,INT(ROW(A1)/6)+2,MOD(ROW(A1),6))"
With .Range("A:B")
.Value = .Value
End With
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1") = "ダミー"
.Range("A1").AutoFilter field:=1, Criteria1:="#VALUE!"
Range(.Cells(2, "A"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).ClearContents
.AutoFilterMode = False
.Range("A1").ClearContents
End With
Application.ScreenUpdating = True
MsgBox "完了"

※ 1行ずつループすると相当の時間を要すると思いますので、
別の方法でやってみました。

こんな感じではどうでしょうか?m(_ _)m
    • good
    • 0

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセルのデータ、1行を複数行に展開し直したいです。

うまく説明できませんが、筆まめの住所録データをCSV形式にてエクセルに落とし込みました。

その状態では、宛名~備考までの項目が約20、A2~S2に1行に
展開されています。

住所録を社内で回覧できる状態にしたいのですが、今のままでは
項目が多すぎるため、1件について3行程度に項目を折りたたんで
展開したいです。

 宛名|敬称|担当者|郵便番号|住所|番地|ビル名|備考
 
 ↓
 
 宛名 | 敬称 |担当者
 郵便番号 | 住所 | 番地 | ビル名
 備考

 という風に。

別シートに「=sheet1!A2」「=sheet1!B2」というように配置し、
以下ドラックすると、データが2件飛ばしになってしまいます。

簡単に展開しなおせる方法を教えて下さい!!

ずっと調べているのですが、一向に分からずに煮詰まってしまいました。

Aベストアンサー

住所録データ1件がA列~S列まであるんですよね。
質問には何も書いていませんが、本当は何件もデータがあって、別シートに1件につき3行で表示したい。と、言うことであっていますか?
例では8項目ですが、本来は19項目あると……。
質問を見ると住所録データが1件しかないような記述でしたので、思い違いでしたらごめんなさい。

とりあえず、7項目、7項目、5項目と別けると仮定します。
別シートのA2に以下を入れ、G4までコピーし、F4とG4の式を削除します。
=INDEX(Sheet1!$A:$S,INT((ROW()-2)/3)+2,COLUMN()+MOD(ROW()-2,3)*7)

次にA2からG4までを選択して下にずらずらっとコピーします。
表示する項目を変えるときは COLUMN()+MOD(ROW()-2,3)*7 が項目になりますので、1~19までの数字を入れてください。

Q(エクセル)複数行のデータを列に整形したい

複数行のデータを列に整形したいと思っています。

画像のように縦に並んでいる「整形前」データを、店名から店名までの間にあるデータをひとつのまとまりとして扱い、「整形後」のようにしたいと思います。(実際のデータ数は3万行ほどあり、手作業では行えません。。)

データを区切る、「店名」は各データに必ず存在するのですが、その他のカラムは存在する場合と存在しない場合があり、行数が一定ではありません。

利用できる関数や方法などがございましたら、教えていただけますでしょうか。

どうぞ、よろしくお願いします。

Aベストアンサー

こんにちは!

元データのA列には必ず「店名」は存在する訳ですね?
そういう前提で、
VBAになってしまいますが・・・

番号と電話が存在しますがどちらも「電話番号」だとします。
元データには「都道府県」となっていますが、整列させたい項目は「住所」となっていますよね?
これでは何かと面倒ですので、
↓の画像の右側がSheet2で1行目項目は
都道府県(住所)に関しては「都道府県」に
番号(電話)は「電話番号」にしています。

以上の下準備ができた上での一例です。

Alt+F11キー → メニュー → 挿入 → 標準モジュール → VBE画面に
↓のコードをコピー&ペーストしてマクロを実行してみてください。
(Alt+F8キー → マクロ → マクロ実行です)

Sub Sample1() 'この行から
Dim i As Long, j As Long, cnt As Long, endRow As Long
Dim wS1 As Worksheet, wS2 As Worksheet, myArea As Range, c As Range
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set myArea = wS2.Range("A1:D1")
endRow = wS2.UsedRange.Rows.Count
If endRow > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(endRow, "D")).ClearContents
End If
cnt = 1
For i = 2 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
If wS1.Cells(i, "A") = "店名" Then
cnt = cnt + 1
wS2.Cells(cnt, "A") = wS1.Cells(i, "B")
Else
Set c = myArea.Find(what:=wS1.Cells(i, "A"), LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
j = c.Column
wS2.Cells(cnt, j) = wS1.Cells(i, "B")
End If
End If
Next i
End Sub 'この行まで

※ 30000行程度データがあるようなのでそこそこ時間を要すると思います。m(_ _)m

こんにちは!

元データのA列には必ず「店名」は存在する訳ですね?
そういう前提で、
VBAになってしまいますが・・・

番号と電話が存在しますがどちらも「電話番号」だとします。
元データには「都道府県」となっていますが、整列させたい項目は「住所」となっていますよね?
これでは何かと面倒ですので、
↓の画像の右側がSheet2で1行目項目は
都道府県(住所)に関しては「都道府県」に
番号(電話)は「電話番号」にしています。

以上の下準備ができた上での一例です。

Alt+F11キー → メニュー → 挿入...続きを読む

Qエクセルで複数の列を1列にまとめる方法

エクセルの1つのシートの複数の列にデータがあって、それを1つの列にまとめる方法を教えてください。
A列のデータの最後の次にB列のデータ、C列のデータと次々にデータをつなげたいのです。
よろしくお願いします。

Aベストアンサー

No.1です。以下でどうでしょう。シート1からシート2へコピーします。
i = 1
For 列 = 1 To 255
For 行 = 1 To Cells(65536, 列).End(xlUp).Row
Sheets("sheet2").Cells(i, 1) = Sheets("sheet1").Cells(行, 列)
i = i + 1
Next
Next

Q【Excel VBA】条件に合うデータの転記

Excel2003を使用しています。

2つのシート間の特定の範囲内で、条件に合うデータを転記したいのですが…

Sheet1(A1:C41) ← 一定範囲
Sheet2(選択範囲) ← 都度、選択範囲取得

Sheet2の選択範囲内で、A列とB列の値が、Sheet1のA列とB列のそれぞれの値と一致した場合、Sheet1のC列の値をSheet2のE列に転記したいのですが、こういう場合、コードはどのように書いたらいいでしょうか?

条件に合ったものを順に転記していくコードは書いたことがあるのですが、特定の範囲内ということや、転記する場所が指定されたりしていて、つまづいています。

よろしくお願いします。

Aベストアンサー

例えばこんなマクロでもできます

Sub Macro1()
Dim idx As Integer
Dim fAdr As String
Dim rng As Range
 If TypeName(Selection) = "Range" Then
  With Selection
   For idx = .Row To .Row + .Rows.Count
    fAdr = ""
    Set rng = Sheets("Sheet1").Range("A1:A41").Find( _
     What:=Cells(idx, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not rng Is Nothing Then
     fAdr = rng.Address
     Do
      If rng.Offset(0, 1).Value = Cells(idx, 2).Value Then
       Cells(idx, 5).Value = rng.Offset(0, 2).Value
       Exit Do
      End If
      Set rng = Sheets("Sheet1").Range("A1:A41").FindNext(rng)
     Loop Until fAdr = rng.Address
    End If
   Next idx
  End With
 End If
End Sub

例えばこんなマクロでもできます

Sub Macro1()
Dim idx As Integer
Dim fAdr As String
Dim rng As Range
 If TypeName(Selection) = "Range" Then
  With Selection
   For idx = .Row To .Row + .Rows.Count
    fAdr = ""
    Set rng = Sheets("Sheet1").Range("A1:A41").Find( _
     What:=Cells(idx, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not rng Is Nothing Then
     fAdr = rng.Address
     Do
      If rng.Offset(0, 1).Va...続きを読む

QExel VBA 別ブックから該当データを検索し、必要なデータを取得する方法について

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数ではなく、マクロで処理を希望します。

自分では、部品表の商品番号をコピーして、コード一覧表で検索し、検索結果の右隣のセル(B列のコード)の値を部品表のC列に貼り付ければよいかと思い、書いてみたんですが…

Sub 別ブックから貼り付ける()
  Dim 検索する As Long
Windows("部品表.xls").Activate
検索する = cells(i,2).Value
Windows("コード一覧表.xls").Activate
ActiveWindow.SmallScroll Down:=-3
Selection.AutoFilter Field:=3, Criteria1:="=検索する", Operator:= xlAnd

と、してみたものの、検索しても、その検索結果の隣のセルのコードをどうやって取得すればいいのかが、わかりませんでした。

基本事項は本で学びましたが、呪文のようなコードはよく理解できません。懸命にネットで検索して、訳して理解する努力をしてはいますが。

どうぞよろしくお願いします。

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数...続きを読む

Aベストアンサー

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks.Open("C:\★★\コード一覧表.xls") '★要変更★
 I = 2
 Do While Range("A" & I).Value <> ""
  ThisWorkbook.Worksheets("Sheet1").Range("C" & I).Value = Application.VLookup(ThisWorkbook.Worksheets("Sheet1").Range("B" & I).Value, xlBook.Worksheets("Sheet1").Range("A2:B65535"), 2, 0)
  I = I + 1
 Loop
 xlBook.Close
 Application.ScreenUpdating = True
 MsgBox ("完了")
End Sub

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks....続きを読む

Q複数条件が一致で別シートに転記【エクセルVBA】

エクセルでセルの条件が複数一致したら別シートに転記される方法をお教えください。
シートを2枚用意して、配達日ごとに一覧化したいのです。
事前に用意したシート(配達表)の“配達”と“配達時間”が一致したら
その方の名前と注文個数を右側に反映したいのですが・・・

注文データが多すぎて困っています。
宜しくお願いします。

■シート名:注文データ
   A    B    C    D    E
------------------------------------------------
1 しめい  対応   配達日   時間   個数
------------------------------------------------
2 たけだ  配達  6/20(月) 13:00  2個
3 みうら  配達  6/18(土) 14:00  4個
4 らもす  郵送  6/20(月)  ―   5個
5 いはら  配達  6/20(月) 14:30  8個
6 かつや  配達  6/20(月) 15:00  6個
7 みうら  郵送  6/20(月)  ―   4個

■シート名:配達表
    A     B    C
------------------------------------
1  配達   6/20(月)
------------------------------------
2  12:00
3  12:30
4  13:00
5  13:30
6  14:30
7  15:00
8  15:30
9  16:00

マクロを実行すると・・・
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

■シート名:配達表
    A     B    C
------------------------------------
1  配達   6/20(月)
------------------------------------
2  12:00 
3  12:30
4  13:00    たけだ   2個
5  13:30
6  14:00    みうら   4個
6  14:30   いはら   8個
7  15:00   かつや   6個
8  15:30
9  16:00

エクセルでセルの条件が複数一致したら別シートに転記される方法をお教えください。
シートを2枚用意して、配達日ごとに一覧化したいのです。
事前に用意したシート(配達表)の“配達”と“配達時間”が一致したら
その方の名前と注文個数を右側に反映したいのですが・・・

注文データが多すぎて困っています。
宜しくお願いします。

■シート名:注文データ
   A    B    C    D    E
------------------------------------------------
1 しめい  対応   配達日   時間   個数
-...続きを読む

Aベストアンサー

こういうのは「複数条件による抜き出し問題」だ。
関数で出来ればおなじみのやり方で良いのだが、既に出ているように式が長く複雑で、初心者には何をやって居るかわからない式になる。毎度週に数回このタイプの質問が出て、同じようなタイプの答えになる。Googleででも「imogasi方式」で照会すれば、過去の沢山の例と回答(そのタイプも)が出てくる。
ーー
まず初心者や急ぐ場合はデーターフィルターフィルタオプションの設定で済ませられないか勉強すべきだ。
ーー
本来、こういう仕事の関連のエクセル表は、VBAを勉強してそれを使うべきと思う(既に回答も出ているようだ)
関数で抜き出し問題や表の組み換えは、VBAで無いと、天下りの長い式をコピペで使うだけになる。
ーー
私が紹介している「imogasi方式」では、Sheet2に時刻の所定の行に出す問題なので複雑になりすぎる。
ーー
VBAでやってみる。
例データ
しめい対応配達日時間個数
たけだ配達6月20日13:002個
みうら配達6月18日14:004個
らもす郵送6月20日ーー5個
いはら配達6月20日14:308個
かつや配達6月20日15:006個
みうら郵送6月20日ーー4個
(注意)
「ーー」セルは空白とする
「月日」列は、エクセルの年月日を入れておくこと(日付シリアル値(わかりますか)) 文字列では不可
6/20(月) の様な表示は、表示形式の設定でやること(エクセルの常識)  m/d(aaa)
時間の列も時刻シリアル値で入れてあるとする。文字列では不可
ーー
コード
標準モジュールに
Sub test01()
Dim sh1, sh2
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("A65536").End(xlUp).Row
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "B") = "配達" And sh1.Cells(i, "C") = sh2.Range("B1") And _
sh1.Cells(i, "D") <> "" Then
t = sh1.Cells(i, "D")
'---Sheet2で時刻行を探す
For r = 2 To 30
If sh1.Cells(i, "D") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をSheet2の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "A")
Sheet2.Cells(r, "C") = sh1.Cells(i, "E")
End If
Next i
End Sub
ーー
実行結果
Sheet2
配達6月20日
12:00
12:30
13:00たけだ2個
13:30
14:00
14:30いはら8個
15:00かつや6個
15:30
16:00
・・・・・・

こういうのは「複数条件による抜き出し問題」だ。
関数で出来ればおなじみのやり方で良いのだが、既に出ているように式が長く複雑で、初心者には何をやって居るかわからない式になる。毎度週に数回このタイプの質問が出て、同じようなタイプの答えになる。Googleででも「imogasi方式」で照会すれば、過去の沢山の例と回答(そのタイプも)が出てくる。
ーー
まず初心者や急ぐ場合はデーターフィルターフィルタオプションの設定で済ませられないか勉強すべきだ。
ーー
本来、こういう仕事の関連のエクセル表...続きを読む

QEXCELで特定のセルに表示された項目をヘッダーやフッターに出力するには

お世話になっております。
タイトルの通りの質問なのですが、
EXCELで特定のセルに表示された項目をヘッダーやフッターに出力するにはどうすればよいのでしょうか?

たとえば、A1のセルに「ABC」と入力されていたとします。
その「ABC」をヘッダーに自動的に出力できるようにしたいのです。
できればマクロは使いたくありません。

宜しくお願いします。

Aベストアンサー

「表示」メニューの「ヘッダーとフッター」では、セル参照を指定することはできません。
「行タイトル」や「列タイトル」しか使用できません。
「行タイトル」を使用するには「ファイル」メニューの「ページ設定」で「シート」タグを選択してください。
ここで「行タイトル」にA1でしたら1行目を選択すればOKです。
ただし、行丸ごとですので注意してください。

Qエクセルで横並びの複数データを縦の一本のデータにしたい

こんにちは。宜しくお願い致します。

   A   B  C
1 静岡 埼玉 
2 福島 東京 愛媛
3 青森 
4 長崎 徳島 愛媛
5 東京 千葉 
6 秋田 兵庫 大阪
.
.
.


例えばこういう形で好きな都道府県の上位3つの解答がそれぞれあったとします。(1個の人もいるし、2個の人もいます)

これを別のシート(同じシートの違う場所でも構いません)に縦並び1本で出したいときどうしたらいいでしょうか。

★こういう風にしたい★

静岡
福島
青森
長崎
東京
秋田
埼玉
東京
愛媛
徳島
愛媛
千葉
兵庫
大阪
.
.

※好きな県などが人によって重複していても構いません、また順不同でもいいです。(縦並びのデータに東京が20個あってもよいということ)

形式を選択して貼り付けで行列を入れ替えるではうまくいかないです。

宜しくお願い致します。

Aベストアンサー

VBAで、もっと簡単に。
下記をVBEの標準モジュールにコピーし貼りつけ。
元データのあるシートで、データのある範囲を範囲指定して(空白セルが範囲内にあっても結構)、下記を実行。
Sub ichiretu()
Dim cl As Range
p = 1
For Each cl In Selection
If cl <> "" Then
Worksheets("sheet3").Cells(p, "A") = cl
p = p + 1
End If
Next
End Sub
Sheet3のA列に並びます。

Q別のシートから値を取得するとき

Worksheets("シート名").Activate
上記のを行ってから別シートの値を取得するのですが、
この処理を行うと指定したシートへ強制的にとんでしまいます。。。

※イメージ
For ~ To ~
  Worksheets("シートA").Activate
  シートAの値取得
       :
  Worksheets("シートB").Activate
  シートBの値取得
Next

このイメージ処理を行うとものすごい勢いで画面がチカチカします。。。
シートを変えずに他のシートから値を取得する方法はないのでしょうか。
教えてください!

Aベストアンサー

Worksheets("シートA").Range("A1")

みたいな感じでできませんか?

QVBAで条件が一致する行のデータを別シートに抽出

"Sheet1"のA列に区分(文字列)、B列~D列に分析数値があり
A列の文字が条件に一致した行のデータを"Sheet2"にコピー、
元の"Sheet1"のデータは行ごと削除といった形で考えているのですが、どうも上手くいきません。

Dim Keywrd As String
???
With Worksheets("Sheet1").Columns("A:A")
Set Keywrd = .Find("キーワード", LookIn:=xlValues)
???
End With
Set Keywrd = Nothing
TargetCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub


???部分の変数宣言と処理内容をどうすれば良いか、ご教授願えますでしょうか。

Aベストアンサー

こんばんは。

#1の回答者です。一度きりなら、こんな風に直してみたらよいと思います。質問のコードは、変数の流れがおかしくなっているようです。

Sub Macro1()
  Dim Keywrd As String
  Dim TargetCell As Range
  Keywrd = InputBox("キーワードを入れてください", "キーワード入力")
  If Keywrd = "" Then Exit Sub
  With Worksheets("Sheet1").Columns("A:A")
    Set TargetCell = .Find(Keywrd, LookAt:=xlWhole, LookIn:=xlValues)
    If TargetCell Is Nothing Then
      MsgBox Keywrd & " は見つかりません。"
      Exit Sub
    End If
  End With
  'Keywrd = "" ''不要
  TargetCell.EntireRow.Copy Worksheets("Sheet2").Range("A1")
  TargetCell.Delete Shift:=xlUp

End Sub

--------------------------------------
#1 のコードを考え直し修正しました。
私のコードは、必ず、検索値に対して複数、該当するものがあるという条件になっています。

---------------------------------------------
Sub TestFind2()
 Dim myKeyWord As String
 Dim FirstAdd As String
 Dim c As Range
 Dim ur As Range
 myKeyWord = Application.InputBox("検索文字を入れてください", "検索+移動", Type:=2)
 If myKeyWord = "" Or myKeyWord = "False" Then Exit Sub

 With Worksheets("Sheet1").Columns(1)
 .Cells(1).Select
 Set c = .Find( _
      What:=myKeyWord, _
      LookIn:=xlValues, _
      LookAt:=xlWhole, _
      MatchCase:=False, _
      MatchByte:=True)

  If Not c Is Nothing Then
     Set ur = c.EntireRow
     FirstAdd = c.Address
    Do
      Set ur = Union(c.EntireRow, ur)
      Set c = .FindNext(c)
    Loop Until (c Is Nothing) Or (FirstAdd = c.Address)
   End If
   ur.Copy Worksheets("Sheet2").Range("A1")
   ur.Delete Shift:=xlShiftUp
End With
   Set ur = Nothing
End Sub


 

こんばんは。

#1の回答者です。一度きりなら、こんな風に直してみたらよいと思います。質問のコードは、変数の流れがおかしくなっているようです。

Sub Macro1()
  Dim Keywrd As String
  Dim TargetCell As Range
  Keywrd = InputBox("キーワードを入れてください", "キーワード入力")
  If Keywrd = "" Then Exit Sub
  With Worksheets("Sheet1").Columns("A:A")
    Set TargetCell = .Find(Keywrd, LookAt:=xlWhole, LookIn:=xlValues)
    If TargetCell Is Nothing Then
...続きを読む


人気Q&Aランキング