マンガでよめる痔のこと・薬のこと

お世話になります。
VBA初心者です、よろしくお願いいたします。
掲題にありますとおり、他のシートの特定の列を検索(抽出?)しアクティブになっているシートの特定の列に貼り付ける作業を自動で行わせたいと思っております。複数ある行の中から必要な行だけを抽出して、貼り付けるのでフォーマットを整えると思っていただければ結構です。具体的には、
[Sheet1]のデータ↓( | ←は罫線と思ってください。列の順番は毎回A→Zの順番とは限りませんが、記載内容は同じです。)
A | B | C | D | E … | Z
1 | 2 | 3 | 4 | 5 … |26
a | b | c | d | e … | z
1a| 2b| 3c| 4d| 5e… |26z
これらのデータから、特定の必要な列を選んで[Sheet2]に貼り付けを自動で行わせたいのです↓。
[Sheet2]B,G,A,W,O,Iのデータのみ必要な場合
B | G | A | W | O | I
2 | 7 | 1 | 23| 15| 9
b | g | a | w | o | i
2b| 7g| 1a|23w|15o| 9i

行数は最大で500行を超えます。HLOOKUPを各セルに書き込んで置けばよいのですが、ドッラグでは式が正しく書き込めなくて。。。
"=HLOOKUP(A1,Sheet1!A:Z,2,0)"←"A1"はA2,A3,A4となるのですが"2"がずっと2のままなので。

[Sheet1]の特定の行のコピー&ペーストなのですが、[Sheet2]の貼り付け先が1行目からではないので、何かしらの工夫が必要だと思うのですが。。。
たとえば
Columns("B:B").Select
Selection.Copy
Sheets("Sheet2").Select
Cells(2, 1).Paste
こう言う事って出来ませんよね?

私の意は伝わりましたでしょうか?なにとぞよろしくお願いいたします。

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

A 回答 (4件)

こんなのではどうでしょうか?



Sub sample()
'初期設定(コピー元とコピー先のシート、コピーする列を設定)
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
Dim copyColumns As String
Set srcSheet = Sheets("Sheet1")
Set dstSheet = Sheets("Sheet2")
copyColumns = "B,G,A,W,O,I"
'
Dim srcRowTop As Long
Dim srcRowBottom As Long
Dim dstRowTop As Long
Dim dstColumnLeft As Integer
Dim cols() As String
Dim i As Integer
'コピー元の最初と最後の行を取得(有効なデータ行は、A列には必ずデータがあるとします)
srcRowTop = 1
srcRowBottom = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row 'A列の最後のデータの行
If (srcRowBottom = 1) And (srcSheet.Cells(1, 1) = "") Then '最後の行が1行目で、実は1行目にデータが無い場合
Exit Sub 'コピー元データなし
End If
'コピー先の最初の行を設定
dstRowTop = 10 'C10の10
dstColumnLeft = 3 'C10のC(=3)
'コピーする列名を配列へ取得
cols = Split(copyColumns, ",")
'コピー開始
For i = 0 To UBound(cols)
srcSheet.Range(cols(i) & srcRowTop & ":" & cols(i) & srcRowBottom).Copy Destination:=dstSheet.Cells(dstRowTop, i + dstColumnLeft)
Next
End Sub

ちなみに、コピー先が変わったら
'コピー先の最初の行を設定
dstRowTop = 10 'C10の10
dstColumnLeft = 3 'C10のC(=3)
の部分を変更してください。
    • good
    • 0
この回答へのお礼

出来ました!C10から張り付いてくれました。
A,B,C…を貼り付ける部分のセルの色が白になってしまうので(コピー先はグレー、元は白)、「srcRowTop = 1」の1を2に変えてみたら1行目を含めずその下の部分をコピーして貼り付けてくれました。親切なDescriptionのおかげです。本当にありがとうございました。
また機会がございましたら、よろしくお願い申し上げます。

お礼日時:2008/04/14 22:58

こんばんは。



>[Sheet2]のBは"C10(=10,3)"のセルから、G="D10", A="E10"…I="H10=(10,8)"と続きます。貴殿の記述ですと"A2"よりPasteが始まります。

私の場合は、* を書き換えればよいはずです。

なお、私の書いていたものは、
>Row1(1行目)には全てデータが入っております。
ということではなく、A列に入っているかどうか、ということです。

 i = 3 '初期値  *
  For Each c In ColLists
    ''補正する場合 j = Cells(1, c).Column - rng.Cells(1, 1).Column + 1
    ''rng.Columns(j).Copy に変える
    rng.Columns(c).Copy Worksheets("Sheet2").Cells(10, i) '*
    
    i = i + 1
  Next c


それと、大勢には影響がないのですが、ルールとして忘れてました。

  Next c
  Set rng = Nothing  '←は、書き加えてください。*
End Sub
    • good
    • 1
この回答へのお礼

Wendy02さん、
こんばんは。出来ましたよ!本当にどうもありがとうございました。
とってもシンプルで処理が早いです。どうすれば貴殿のようになれるのでしょう。。。自己紹介を読ませていただきましたが、どうやら趣味のようで。。。地道に勉強して行こうと思っております。また機会がございましたら、よろしくお願い申し上げます。

お礼日時:2008/04/15 21:00

こんにちは。



あまり、難しく考える必要はないと思います。

ただ、注意としては、基本的な考え方としては、範囲(rng)に対する列の列数で、厳密にいうと、A,B,Cという列数というワークシートの列ではありませんが、それさえ、気をつければ、以下のような簡単なコードで済みます。

B列からデータが始まれば、B列が、1列目, C列が、2列目になります。
つまり、Sheet1 のA列からデータがないと、補正しなくてはならない、ということになります。
言い換えると、論理的な列数で、物理的な列名とは違います。

例:データがA列から始まらないばあは、補正します。
 列数(j) = Cells(1, c).Column - rng.Cells(1, 1).Column + 1

'------------------------------------------

Sub Test1()
  Dim ColLists As Variant
  Dim c As Variant
  Dim i As Integer
  'Dim j As Integer A列からデータばない時、補正が必要
  Dim rng As Range
  Const COLLIST As String = "B,G,A,W,O,I"
  ColLists = Split(COLLIST, ",")
  'データ範囲
  Set rng = Worksheets("Sheet1").Range("A1").CurrentRegion
  i = 1 '初期値
  For Each c In ColLists
    ''補正する場合 j = Cells(1, c).Column - rng.Cells(1, 1).Column + 1
    ''rng.Columns(j).Copy に変える
    rng.Columns(c).Copy Worksheets("Sheet2").Cells(2, i)
    i = i + 1
  Next c
End Sub
    • good
    • 1
この回答へのお礼

Wendy02さん
早速のご指導ありがとうございます。前回お書きいたしましたとおり、私は全くの初心者でございまして、双方とも試させていただきましたが、もう少しの微調整が出来ずにおります。[Sheet1]の"A"はA1にありB1>C1…Z1と続きます。Row1(1行目)には全てデータが入っております。コピー先の
[Sheet2]のBは"C10(=10,3)"のセルから、G="D10", A="E10"…I="H10=(10,8)"と続きます。貴殿の記述ですと"A2"よりPasteが始まります。
どのように書き換えればよろしいのでしょうか?勝手言って申し訳ございませんが、なにとぞよろしくお願いいたします。

お礼日時:2008/04/14 20:39

こんなのではどうでしょうか?



Sub sample()
'初期設定(コピー元とコピー先のシート、コピーする列を設定)
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
Dim copyColumns As String
Set srcSheet = Sheets("Sheet1")
Set dstSheet = Sheets("Sheet2")
copyColumns = "B,G,A,W,O,I"
'
Dim srcRowTop As Long
Dim srcRowBottom As Long
Dim dstRowTop As Long
Dim cols() As String
Dim i As Integer
'コピー元の最初と最後の行を取得(有効なデータ行は、A列には必ずデータがあるとします)
srcRowTop = 1
srcRowBottom = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row 'A列の最後のデータの行
If (srcRowBottom = 1) And (srcSheet.Cells(1, 1) = "") Then '最後の行が1行目で、実は1行目にデータが無い場合
Exit Sub 'コピー元データなし
End If
'コピー先の最初の行を取得(有効なデータ行は、A列には必ずデータがあるとします)
dstRowTop = dstSheet.Cells(dstSheet.Rows.Count, 1).End(xlUp).Row + 1 'A列の最後のデータの行+1
If (dstRowTop = 2) And (dstSheet.Cells(1, 1) = "") Then '最初の行が2行目で、実は1行目にデータが無い場合
dstRowTop = 1 'コピー先データなし(コピー先は先頭行から)
End If
'コピーする列名を配列へ取得
cols = Split(copyColumns, ",")
'コピー開始
For i = 0 To UBound(cols)
srcSheet.Range(cols(i) & srcRowTop & ":" & cols(i) & srcRowBottom).Copy Destination:=dstSheet.Cells(dstRowTop, i + 1)
Next
End Sub
    • good
    • 0
この回答へのお礼

fumufumu_2006さん,
早速のご指導ありがとうございます。前回お書きいたしましたとおり、私は全くの初心者でございまして、双方とも試させていただきましたが、もう少しの微調整が出来ずにおります。[Sheet1]の"A"はA1にありB1>C1…Z1と続きます。Row1(1行目)には全てデータが入っております。コピー先の
[Sheet2]のBは"C10(=10,3)"のセルから、G="D10", A="E10"…I="H10=(10,8)"と続きます。貴殿の記述ですと"A1"からpasteが始まります。
どのように書き換えればよろしいのでしょうか?勝手言って申し訳ございませんが、なにとぞよろしくお願いいたします。

お礼日時:2008/04/14 20:41

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

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

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

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

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

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別のシートから値を取得するとき

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[初心者です]VBAで指定列からAを検索し、発見したら隣のセルに値0を入れるマクロ。

VBAで指定列からAを検索し、発見したら隣のセルに0を入れるマクロを組みたいのですが、組み方がVBA初心者の為わかりません。
(例)
L列に、A、B、C、D、E、Fとランダムに文字が入っていて、
文字Aを検索し、発見したら隣のI列に値0を入れるというマクロです。

Sub Search()
Dim A As String
Set A = Worksheets("Sheet1").Cells.Find("A")
If A Is Nothing Then
ActiveCell.Offset(0, 1).Value = 0

End If
End Sub
と過去の質問で考えてみたのですが、Aがあった時、、、、
とコードが書けないです。
大変困っているので、ご教授頂けないでしょうか?
出来れば、そのままマクロに出来るコードを教えて頂けないでしょうか?
宜しくお願い致します。

Aベストアンサー

こんばんは。

#3さんのおっしゃっていることも、もっともなのですが、気になる点がありましたので、自分のことを踏まえて、書かせていただきます。

いずれ、また、同じようなケースが出会うと思います。こんな原則を考えてみたらどうでしょうか?それは、私も自身も同じなのですが、ワークシートのコマンドで行われるものは、記録マクロから作ってみるということです。他にも、「統合」とか、「置換」とか「オートフィルタ」「フィルタオプション」とかは、みんなパターンが決まっています。
その中の代表格が、この「Find」 です。

>Set A = Worksheets("Sheet1").Cells.Find("A")

>過去の質問で考えてみたのです

どうも、Find メソッドは、あるレベル以下の人は、省略する傾向があるようです。何が大事で、何が大事でないかというのは、やってみなければ分かりませんが、検索語だけを入れる書き方は、実務では、あまりしないほうがよいと思います。

だいたい、以下のTestFind2 ぐらいまでに、省略は、とどめたほうがよいです。

それは、Find は、必ずしも自分が思っているデフォルトとは違うことがあるので、「明示的(意図的に)」にオプションは入れたほうがよいです。
例えば、大文字小文字の違いを付けるなら、MatchCase:=True, 数式まで探すなら、LookIn:=xlFormulas

なお、Find メソッドは、5年経っても、たぶん完全に覚えられません。面倒なコードのひとつです。ですが、これはパターンが決まっているので、ひとつパターンが決まったら、それに当てはめればよいだけです。

#3さんで示されているMougのサンプルコードと似てはいるのですが、Mougのサンプルコードでは、Verionによって、失敗することがあります。

'--------------------------------------
'記録マクロをそのまま使う方法
Sub TestFind1()
Dim c As Range
 Set c = Columns("L:L").Find(What:="A", _
           After:=ActiveCell, _
           LookIn:=xlValues, _
           LookAt:=xlPart, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlNext, _
           MatchCase:=False, _
           MatchByte:=False, _
           SearchFormat:=False)
 c.Offset(0, 1).Value = 0
End Sub
'--------------------------------------
'TestFind1 をアレンジしてみる
Sub TestFind2()
Dim c As Range
'検索語
Const MYTXT As String = "A"
 Set c = ActiveSheet.Columns("L:L").Find(What:=MYTXT, _
           LookIn:=xlValues, _
           LookAt:=xlPart, _
           MatchCase:=False)
 If Not c Is Nothing Then
    c.Offset(0, 1).Value = 0
 End If
End Sub

'---------------------------------------
'複数ある場合(パターンを使った方法)
'---------------------------------------
Sub TestFind3()
  Dim c As Range
  Dim FirstAdd As String
  Const MYTXT As String = "A"
  Set c = ActiveSheet.Columns("L:L").Find( _
    What:=MYTXT, _
    LookIn:=xlValues, _
    LookAt:=xlPart, _
    MatchCase:=False)
  
  If Not c Is Nothing Then
    FirstAdd = c.Address
    Do
      c.Offset(, 1).Value = 0
      Set c = ActiveSheet.Columns("L:L").FindNext(c)
      If c.Address = FirstAdd Then Exit Sub
    Loop Until c Is Nothing
  End If
End Sub

こんばんは。

#3さんのおっしゃっていることも、もっともなのですが、気になる点がありましたので、自分のことを踏まえて、書かせていただきます。

いずれ、また、同じようなケースが出会うと思います。こんな原則を考えてみたらどうでしょうか?それは、私も自身も同じなのですが、ワークシートのコマンドで行われるものは、記録マクロから作ってみるということです。他にも、「統合」とか、「置換」とか「オートフィルタ」「フィルタオプション」とかは、みんなパターンが決まっています。
その中の代表...続きを読む

Qエクセルで、条件に一致した行を別のセルに抜き出す方法

エクセルで、指定した条件に一致するセルを含む行をすべて抜き出す方法が知りたいです。

たとえば、

<A列> <B列> <C列>
7/1 りんご 100円
7/2 ぶどう 200円
7/2 すいか 300円
7/3 みかん 100円

このような表があって、100円を含む行をそのままの形で、
別のセル(同じシート内)に抜き出したいのですが。

7/1 りんご 100円
7/3 みかん 100円

抽出するだけならオートフィルターでもできますが、
抽出結果を自動的に、別の場所に、常に表示させておきたいのです。

初歩的な質問だと思いますが、検索しても分からなかったので、よろしくお願いします。

Aベストアンサー

同じ質問が結構よく出てますが、そんなに初歩的でもありません
別シートのA1セルに「100円」と入力し、そのシートの任意のセルに以下の式を貼り付けて下さい。後は、下方向、右方向にコピー。
日付のセル書式は「日付」形式に再設定してください

=IF(COUNTIF(Sheet1!$C:$C,$A$1)>=ROW(A1),INDEX(Sheet1!A:A,LARGE(INDEX((Sheet1!$C$1:$C$500=$A$1)*ROW(Sheet1!$C$1:$C$500),),COUNTIF(Sheet1!$C:$C,$A$1)-ROW(A1)+1)),"")

データ範囲は500行までとしていますが、必要に応じて変更して下さい

Q特定の行を選択して別のシートにコピーするマクロ

指定した行と、
特定の文字(複数)がある行を
全て選択し、別のシートにコピーする
マクロをお教えいただけませんか?

 選択したい行は(同じシートで)
 必ず3行目と、
 A列に『ABC』、『DEF』という文字がある全ての行です。


このようなマクロはどのように作ればいいでしょうか?
マクロに詳しい方、お知恵をお貸し頂けませんでしょうか?

Aベストアンサー

補足を読みました。
値としてSheet2に表示すれば良い訳ですね。

前回のコードに手を加えるとすると

Sub Sample4()
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.Clear
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
With .Rows(3 & ":" & lastRow)
.AutoFilter field:=1, Criteria1:="*ABC*", Operator:=xlOr, Criteria2:="*DEF*"
.SpecialCells(xlCellTypeVisible).Copy
wS.Activate
ActiveSheet.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues
End With
.AutoFilterMode = False
End With
End Sub

こんな感じでしょうか!

尚上記方法はオートフィルタでやっていますので、データ量が多くない場合は
For~Nextでループさせても良いと思います。
参考程度でそのコードは

Sub Sample5()
Dim i As Long, lastCol As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.Clear
With Worksheets("Sheet1")
lastCol = .UsedRange.Columns.Count
wS.Range("A1").Resize(, lastCol).Value = .Range("A3").Resize(, lastCol).Value
For i = 4 To .Cells(Rows.Count, "A").End(xlUp).Row
If InStr(.Cells(i, "A"), "ABC") > 0 Or InStr(.Cells(i, "A"), "DEF") > 0 Then
wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, lastCol).Value = _
.Cells(i, "A").Resize(, lastCol).Value
End If
Next i
End With
End Sub

でも同様の結果になると思います。m(_ _)m

補足を読みました。
値としてSheet2に表示すれば良い訳ですね。

前回のコードに手を加えるとすると

Sub Sample4()
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.Clear
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
With .Rows(3 & ":" & lastRow)
.AutoFilter field:=1, Criteria1:="*ABC*", Operator:=xlOr, Criteria2:="*DEF*"
.SpecialCells(xlCellTypeVisible).Copy
wS.Activate
ActiveSheet.Range("A1").Select
Selection.Paste...続きを読む

QEXCEL VBA 別シートの文字をシート内で検索

excel2003 VBAで SHEET2に格納されているセルの文字をSHEET1のB列1~9000程度までの文字列の中で一致または部分一致するものがあればそのセル(B列のセル)をSHEET3に順次A列に出力したいのですが、うまくできません。SHEET2に格納されている場所はA列で(SHEET1、SHEET2の文字とも増える可能性あり)

宜しくお願いします。

Aベストアンサー

sub macro1r1()
 dim h as range
 dim c as range
 dim c0 as string

 worksheets("Sheet3").cells.clearcontents
 for each h in worksheets("Sheet2").range("A1:A" & worksheets("Sheet2").range("A65536").end(xlup).row)
  if h <> "" then
   set c = worksheets("Sheet1").range("B:B").find(what:=h.value, lookin:=xlvalues, lookat:=xlpart)
   if not c is nothing then
    c0 = c.address
    do
     worksheets("Sheet3").range("A65536").end(xlup).offset(1).value = c.value
     set c = worksheets("Sheet1").range("B:B").findnext(c)
    loop until c.address = c0
   end if
  end if
 next

 worksheets("Sheet3").select
 range("A1:B1") = array("res", "work")
 range("B2:B" & range("A65536").end(xlup).row).formula = "=MATCH(A2,Sheet1!B:B,0)"
 range("A:B").sort key1:=range("B1"), order1:=xlascending, header:=xlyes
 range("B:B").clearcontents
end sub


sub macro2r1()
 dim Target as range
 dim Crit as range
 dim r as long

 worksheets("Sheet3").cells.clearcontents
 with worksheets("sheet1")
 .range("1:1").insert shift:=xlshiftdown
 .range("B1") = "myList"
 set target = .range(.range("B1"), .range("B65536").end(xlup))
 end with

 with worksheets("sheet2")
 .range("1:1").insert shift:=xlshiftdown
 .range("B:B").insert shift:=xlshifttoright
 .range("A1:B1") = "myList"
 r = .range("A65536").end(xlup).row
 with .range("B2:B" & r)
  .formula = "=""*""&A2&""*"""
  .value = .value
 end with
 set crit = .range("B1:B" & r)
 end with

 target.advancedfilter _
  action:=xlfiltercopy, _
  criteriarange:=crit, _
  copytorange:=worksheets("Sheet3").range("A1"), _
  unique:=false

 worksheets("Sheet2").range("B:B").delete shift:=xlshifttoleft
 worksheets("Sheet2").range("1:1").delete shift:=xlshiftup
 worksheets("Sheet1").range("1:1").delete shift:=xlshiftup
end sub

sub macro1r1()
 dim h as range
 dim c as range
 dim c0 as string

 worksheets("Sheet3").cells.clearcontents
 for each h in worksheets("Sheet2").range("A1:A" & worksheets("Sheet2").range("A65536").end(xlup).row)
  if h <> "" then
   set c = worksheets("Sheet1").range("B:B").find(what:=h.value, lookin:=xlvalues, lookat:=xlpart)
   if not c is nothing then
    c0 = c.address
    do
     worksheets("Sheet3").range("A65536").end(xlup).offset(1).value =...続きを読む

QVBAで検索して、行をコピー&追加したい

Excel2010で以下のことをしたいのですが、VBAがあまりできないのでやれません。
どうか助けてください。

・sheet1のA列に検索用の番号(例として商品番号)が入力されています。
・sheet2はデータベースで、A列に商品番号B列に商品名、C列に国名、D列に価格・・~その後J列まで情報が入っています。(行数は1万行)
・sheet1に入っている商品番号でデータベースから行をピックアップし、該当の行をsheet1のB列以降にコピーしたいのです。
(シート3を新しく作っても構いません。やりやすい方で)
・ただし、同じ商品番号で複数の行がヒットしますので、複数の行がヒットしたら行を追加しながら、行をコピーしたいです。

どのように書いたら良いか参考になるURLだけでもご教授ください。
よろしくお願いします。

Aベストアンサー

もう回答が付いてますね、でもせっかく書いたのだからあげときます(笑)

Sub main()

Dim i1 As Long, i2 As Long, i3 As Long
Dim LastRow1 As Long, LastRow2 As Long

'各シートのデータの最終行を取得
LastRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LastRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
i3 = 1

Worksheets.Add 'ワークシート3を作成
ActiveSheet.Name = "Sheet3"
'シート1の文字列がシート2にあるか探し、あればシート2の該当行をシート3にコピー
For i1 = 1 To LastRow1
For i2 = 1 To LastRow2
If Worksheets("Sheet2").Cells(i2, 1) = Worksheets("Sheet1").Cells(i1, 1) Then
Worksheets("Sheet2").Cells(i2, 1).EntireRow.Copy Destination:=Worksheets("Sheet3").Rows(i3)
i3 = i3 + 1
End If
Next i2
Next i1

End Sub

もう回答が付いてますね、でもせっかく書いたのだからあげときます(笑)

Sub main()

Dim i1 As Long, i2 As Long, i3 As Long
Dim LastRow1 As Long, LastRow2 As Long

'各シートのデータの最終行を取得
LastRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LastRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
i3 = 1

Worksheets.Add 'ワークシート3を作成
ActiveSheet.Name = "Sheet3"
'シート1の文字列がシート2にあ...続きを読む

QエクセルVBA 別シートの複数のセルの値をコピーする方法

いつもお世話になります。

Dim sh1, sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")

sh1.Range("C6").Value = sh2.Range("F5").Value
として、1つのセルの値ならコピーできるのですが、
sh1.Range("C6:C10").Value = sh2.Range("F5;F9").Value
としても、セルの値を持ってくることができません。
どのように書けば良いのでしょうか?

ちなみに今は、
sh2.Range("F5:F9").Copy
sh1.Range("C5:C9").PasteSpecial Paste:=xlValues
としているのですが、上記だとセルを範囲指定してしまって作業が見えるのでカッコ悪いのです。

Aベストアンサー

7-samuraiの質問ですみません。
No5のimogasiさん、いつもお世話様です。

Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet2")
Set sh2 = Worksheets("sheet1")
sh1.Range("c1:c5").Value = sh2.Range("A1:A5").Value
End Sub

で、うまくいきますよ。
複数セルの場合Valueは省略できないようです。

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方式」で照会すれば、過去の沢山の例と回答(そのタイプも)が出てくる。
ーー
まず初心者や急ぐ場合はデーターフィルターフィルタオプションの設定で済ませられないか勉強すべきだ。
ーー
本来、こういう仕事の関連のエクセル表...続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング