エクセルマクロ Vlookupに似たマクロはありますか？

質問

度々すみません。
わからない事がいくつか出てきてしまって。どなたかご教示いただけると嬉しいです。

今は手作業で以下のような作業をしております。

データ元のシート（以下(1)）とそれ加工して作るシート（以下(2)）があります。
(1)のデータを2度sortするのですが、一度目のsortでtotalが入っている行は全てdelete。
残ったデータでもう一度sortし、種類別に並び変えます。
その後、コラムAがUSDである物はシート(2)のUSDページに貼り付け、コラムAがEURであればシート(2)のEURページに貼り付け・・・としていきたいのですが、マクロの記録を使おうにも、毎回コラムAは目視で確認しコピー・貼り付けをしていますのでマクロの記録は使えないですし、エクセル関数ではVLOOKUPがありますが、それをマクロに書き込む方法もどこにも載っておらず、どうしていいか息詰まった状態です。

sortするのはマクロの記録を使って作成できましたので、
・コラムAがtotalになっている行より下はdelete
・コラムAがUSDならシート(2)のUSDシートへ貼り付け・・・
のマクロを作成したいです。

どうか宜しくお願い致します。

回答No.18

n-jun · ベストアンサー

>12枚のデータ元のページのうち、データがあるもののみtotalに貼り付けたいのですが
>何か使えるマクロはありますでしょうか。

http://okwave.jp/qa4200665.html
のANo.4での回答に類似。
各シートのセルＡ１にデータがある場合コピペする。

Sub　try()
　　Dim　ws1　As　Worksheet
　　Dim　ws2　As　Worksheet
　　Dim　r1　As　Range,　r2　As　Range

　　Set　ws1　=　Worksheets("total")　'纏めるシート
　　Set　r1　=　ws1.Range("A3")

　　ws1.Cells.ClearContents
　　For　Each　ws2　In　Worksheets
　　　　　　　　　　If　ws2.Name　<>　ws1.Name　Then
　　　　　　　　　　　　　If　ws2.Range("A1").Value　<>　""　Then
　　　　　　　　　　　　　　　　With　ws2
　　　　　　　　　　　　　　　　　　　　　　　　　　Set　r2　=　.Range("A1",　.Cells(Rows.Count,　1)　_
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.End(xlUp).Resize(,　16))
　　　　　　　　　　　　　　　　End　With
　　　　　　　　　　　　　　　　r2.Copy　r1
　　　　　　　　　　　　　　　　With　r1.Resize(r2.Rows.Count,　16)
　　　　　　　　　　　　　　　　　　　　　　　　　　With　.Borders(xlEdgeLeft)
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.LineStyle　=　xlContinuous
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.Weight　=　xlMedium
　　　　　　　　　　　　　　　　　　　　　　　　　　End　With
　　　　　　　　　　　　　　　　　　　　　　　　　　With　.Borders(xlEdgeTop)
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.LineStyle　=　xlContinuous
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.Weight　=　xlMedium
　　　　　　　　　　　　　　　　　　　　　　　　　　End　With
　　　　　　　　　　　　　　　　　　　　　　　　　　With　.Borders(xlEdgeBottom)
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.LineStyle　=　xlContinuous
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.Weight　=　xlMedium
　　　　　　　　　　　　　　　　　　　　　　　　　　End　With
　　　　　　　　　　　　　　　　　　　　　　　　　　With　.Borders(xlEdgeRight)
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.LineStyle　=　xlContinuous
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.Weight　=　xlMedium
　　　　　　　　　　　　　　　　　　　　　　　　　　End　With
　　　　　　　　　　　　　　　　End　With
　　　　　　　　　　　　　　　　Set　r1　=　r1.Offset(r2.Rows.Count　+　1)
　　　　　　　　　　　　　End　If
　　　　　　　　　　End　If
　　Next
End　Sub
こうゆう事でしょうか？

お礼

動きはピッタリです。

二点質問があります。

(1)前回のマクロに関してなのですが、通貨毎に、対応する各々のシートに貼り付ける際、値貼りにしたいのです。（コラムAに色が塗ってあり、値貼りにより白字にしているので）
マクロの中にPasteという文言がないのですが、PasteではなくValue　Pasteにするにはどの行を変更すれば宜しいでしょうか？

(2)No18で教えていただいたマクロを走らせると、sheet1の1～2行目に書いてあった文字等が消えてしまっているのですが、マクロの中にdeleteの文言がないのですが、どの行を変更すれば宜しいでしょうか？

本当にすみません。

回答No.25

n-jun

>ここでいうデータは
>Set ws1 = Worksheets("Summary") '纏めるシート
>と同じシート名ですよね？
>見えにくいスペースなどあるのかと思い、再度Re nameして試みてみましたが同じ結果でした。
With Worksheets("data")
ワークシート"data"の事です。

纏める時にワークシート"Summary"と ワークシート"data"を除外したい
と言う事になります。

お礼

間違えてSummaryを記入していました。
今、訂正し試したところ、うまくいきました！
n-junさん、長い間、本当にありがとうございました。何回もつきあっていただけて、こんないい人いるんだなと本当に感謝しております。

何度言っても言い足りませんが、長期間にわたってありがとうございました！！

回答No.24

n-jun

>If ws2.Name <> ws1.Name Thenと
>If ws2.Name <> ws1.Name And ws2.Name <> "data" Then、
>同じ結果になってしまいます。。。
dataの名前はあってますよね。大文字・小文字・スペースの有無等。

お礼

ここでいうデータは

Set ws1 = Worksheets("Summary") '纏めるシート

と同じシート名ですよね？

見えにくいスペースなどあるのかと思い、再度Re nameして試みてみましたが同じ結果でした。

回答No.23

n-jun

>でも、データを集結したsummryシートが何故か全通貨貼り付け終わった次の行に
>【Sub　try2（）の中のWith Worksheets("data")シートの】の内容をコピ-してしまっています。
>If ws2.Name <> ws1.Name Then
If ws2.Name <> ws1.Name And ws2.Name <> "data" Then
でどうでしょう。

お礼

If ws2.Name <> ws1.Name Thenと
If ws2.Name <> ws1.Name And ws2.Name <> "data" Then、
同じ結果になってしまいます。。。

回答No.22

n-jun

>三個を連続でさせたかったのですが、どうもうまく回らず別々にしました。
>三個目のマクロが全く起動しません。エラーもなく何も変化なし。
こちらで検証した範囲では問題ないのですが、実際のデータとBookで
デバッグをしていかないと難しいです。
起動しないとは、実行しても集計がまとまらない？と言う事であれば、
必要なシートを選択しているのか（For Each～Next）、
データ範囲を取得できているのか（r2のアドレス）等々の確認をしていくしかないです。

お礼

集計が始まらない（空回りしているみたいに）というか各々通貨シートにもコピーが始まらないのです。
デバックすら出ないのです。。。

もうちょっと試してみますね。

う～ん。。。なんででしょう・・・

補足

自分で書いていて「うん？？」と気付きました。
マクロ2がうまくいっていたようでいっていなかったみたいです。
修正したら、無事出来ました！

でも、データを集結したsummryシートが何故か全通貨貼り付け終わった次の行に【Sub　try2（）の中のWith Worksheets("data")シートの】の内容をコピ-してしまっています。

回答No.21

n-jun

>集結するシートの1～2行目を消したくないのですが、
だけであれば、ANo.18のコードの
ws1.Cells.ClearContents
を
ws1.Range("A3").Resize(Rows.Count - 2, Columns.Count).ClearContents
に変更するだけです。

>Dim ws As Worksheet
>For Each ws In Worksheets
>If ws.Name <> "total" Then　'消したくないシート名を記入
>ws.Cells.ClearContents
>End If
>Next
>上記を振り分ける前の所に追加する。
は不要です。

>Duplicate　declaration　in　current　scopeとエラーが出るようになりました。
ここについては、未だ経験のないエラー（？）なので、ちょっとわかりません。
ただ、上記追加をお願いしたコードが悪さをしているのかな？と
思いますので、削除してみて下さい。

お礼

三個を連続でさせたかったのですが、どうもうまく回らず別々にしました。三個目のマクロが全く起動しません。エラーもなく何も変化なし。
(1)Sub Macro1()
Range("A1").Select
ChDir "R:\P&L\Treas_Trade_to_mark"
Workbooks.OpenText Filename:= _
"R:\P&L\Treas_Trade_to_mark\trade to mark", Origin:=932, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True, Comma:=False, _
Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array( _
3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10 _
, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
Array(17, 1)), TrailingMinusNumbers:=True
Selection.AutoFilter
Selection.AutoFilter Field:=8, Criteria1:="<>*Total*", Operator:=xlAnd
Cells.Select
Selection.Copy
With ActiveWindow
.Top = 54.25
.Left = 264.25
End With
Windows("Do loop Book2.xls").Activate
Sheets("Murex data").Activate
ActiveSheet.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub
(2)Sub try2()
Dim r As Range
Dim i As Long, j As Long
Dim m As Integer
Dim v, vv
Dim n As Integer, ch As Boolean
ch = False
With Worksheets("data")
v = .Range(.Range("A2"), .Cells(Rows.Count, 1) _
.End(xlUp).Resize(, 16)).Value
ReDim vv(1 To UBound(v, 1), 1 To 16)
For i = 1 To UBound(v, 1)

補足

For n = 1 To 16
If InStr(v(i, n), "total") = 0 And _
InStr(v(i, n), "Total") = 0 And _
LenB(v(i, n)) > 0 Then _
ch = True
Next
If ch = True Then
j = j + 1
For m = 1 To 16
vv(j, m) = v(i, m)
Next
ch = False
End If
ext
ws1.Range("A3").Resize(Rows.Count -2,Columns.Count).ClearContents
'.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp) _
.Resize(, 16)).ClearContents
.Range("A2").Resize(j, 16).Value = vv
.Range("A2").Resize(j, 16).Sort Key1:=.Range("A2"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End With
　　　For i = 1 To j
With Worksheets(Trim(vv(i, 1)))
If .Range("A1").Value = "" Then
Set r = .Range("A1")
Else
Set r = .Range("A" & Rows.Count) _
.End(xlUp).Offset(1)
Set r = Nothing
Erase v, vv
End Sub
End If
For m = 1 To 16
r.Offset(, m - 1).Value = vv(i, m)
Next
End With
Next
Erase v, vv
End Sub
（3）Sub try3()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim r1 As Range, r2 As Range

Set ws1 = Worksheets("Summary") '纏めるシート
Set r1 = ws1.Range("A3")

ws1.Range("A3").Resize(Rows.Count - 2, Columns.Count).ClearContents

'ws1.Cells.ClearContents
For Each ws2 In Worksheets
If ws2.Name <> ws1.Name Then
If ws2.Range("A1").Value <> "" Then
With ws2
Set r2 = .Range("A1", .Cells(Rows.Count, 1) _
.End(xlUp).Resize(, 16))
End With
r2.Copy r1
With r1.Resize(r2.Rows.Count, 16)
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End With
Set r1 = r1.Offset(r2.Rows.Count + 1)
End If
End If
Next
End Sub

回答No.20

n-jun

>totalシートの2行目までは毎回残しておきたいです。
ws1.Range("A3").Resize(Rows.Count - 2, Columns.Count).ClearContents

>その場合は一枚一枚のシートで全範囲を選択し削除、
振り分ける前の各々の通貨シートのことですか？

Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "total" Then　'消したくないシート名を記入
ws.Cells.ClearContents
End If
Next
上記を振り分ける前の所に追加する。

>Paste:=xlPasteValues
値のみをペーストすることと、値を代入することは同じはずですが。
例えばセルＢ１の値をＡ１に入れたい場合、
Range("B1").Copy
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
と
Range("A1").Value = Range("B1").Value
は同じ結果になります。
配列を用いていますが、後者と同じ事をしています。

>コラムAの文字が白くなる為
ここがよくわかりません。
データの代入だけでは文字色が変更されることはないはずです。
条件付き書式が設定されているのではないですか？

お礼

紛らわしかったですよね。
集結するシートの1～2行目を消したくないのですが、
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "total" Then　'消したくないシート名を記入
ws.Cells.ClearContents
ws1.Range("A3").Resize(Rows.Count - 2,Columns.Count).ClearContents

でしょうか？

書き換えて試そうとしているのですが、今になって昨日までRun出来たのに

＞'各々のデータをSummaryへ集結させる
Dim ws1 As Worksheet

で、Duplicate　declaration　in　current　scopeとエラーが出るようになりました。
特にこの文章をDupliで書き込んでいるわけではないのですが。。。

＞データの代入だけでは文字色が変更されることはないはずです。

そうですよね、白字に勝手になるので書式設定されているようです。
マクロではその書式設定が効かないです。
色変換マクロを組んでくっつけます。

回答No.19

n-jun

>(1)前回のマクロに関してなのですが、通貨毎に、対応する各々のシートに貼り付ける際、値貼りにしたいのです。（コラムAに色が塗ってあり、値貼りにより白字にしているので）
>マクロの中にPasteという文言がないのですが、PasteではなくValue　Pasteにするにはどの行を変更すれば宜しいでしょうか？
Value Pasteって何でしょう？
各々のシートにはデータが代入されるはずですが。
（セルの文字色を白にしてもデータがあれば振り分けられます。）

>(2)No18で教えていただいたマクロを走らせると、sheet1の1～2行目に書いてあった文字等が消えてしまっているのですが、
>マクロの中にdeleteの文言がないのですが、どの行を変更すれば宜しいでしょうか？
削除処理はシート名"total"だけですが。
　ws1.Cells.ClearContents
の部分で全てのセルに対してデータのクリアを行なっています。

お礼

（1）
間違えました、Paste Valueでした。
PCが英語の環境なので、そのまま書くとEdit→Paste Special→Value
の貼り付けです。
各々のシートのコラムAに色が塗ってあり、単純な貼り付けだと見にくいので
上記の方法で貼り付けています（コラムAの文字が白くなる為）
マクロ単体だとコレだと思うのですが。
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

（2）
totalシートの2行目までは毎回残しておきたいです。
その場合は一枚一枚のシートで全範囲を選択し削除、totalシートのみ3行目以下を削除と、マクロを何個も書く事になりますか？

回答No.17

n-jun

>With Worksheets(vv(i, 1))
>が部分で黄色が出ます。
コピペしたデータから余分なデータは削除し、その後に残るＡ２以下の
Ａ列のデータと同じ名前のWorkSheetが存在していない事になります。

若しくはデータに不要な空白があるのかも。
これならば、
With　Worksheets(Trim(vv(i, 1)))
で対応できるはずです。

お礼

無事、走りました！
本当にありがとうございました！

あともう一点だけお伺いしても宜しいでしょうか・・・

私が作業しているbookは
AUDやUSD等のデータを貼り付けるページが他に10枚、それら10枚を最終的に貼り付けるページが一枚（以下totalを呼ぶ）あります。
12枚のデータ元のページのうち、データがあるもののみtotalに貼り付けたいのですが何か使えるマクロはありますでしょうか。

今までは通貨数もそこまで多くなく毎回全通貨が存在したのですが、最近は存在するものとしないものが日によって出てきまして、今まで使っていた単純なコピーペーストが使えなくなってしまいました。。。

Sheets("USD").Activate
ActiveSheet.Range("A1").Select
ActiveSheet.Range("A1:P1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

今までの使用マクロです。これを各々の通貨で使用。
Sheets("sheet1").Activate

ActiveSheet.Paste
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

Application.CutCopyMode = False
ActiveSheet.Range("A65536").End(xlUp).Offset(2, 0).Select

回答No.16

n-jun

Downloadしたファイルを一度開いたあとに、コードを書いたBookの
Sheet1にコピペする。（Sheet1は事前に準備）

あとは以下でどうでしょう？

　Sub　test3()
　　　Dim　r　As　Range
　　　Dim　i　As　Long,　j　As　Long
　　　Dim　m　As　Integer
　　　Dim　v,　vv
　　　Dim　n　As　Integer,　ch　As　Boolean

　　　ch　=　False
　　　With　Worksheets("Sheet1")
　　　　　　　　v　=　.Range(.Range("A2"),　.Cells(Rows.Count,　1)　_
　　　　　　　　　　　　.End(xlUp).Resize(,　16)).Value
　　　　　　　　ReDim　vv(1　To　UBound(v,　1),　1　To　16)
　　　　　　　　For　i　=　1　To　UBound(v,　1)

　　　　　　　　　　　　For　n　=　1　To　16
　　　　　　　　　　　　　　　　If　InStr(v(i,　n),　"total")　=　0　And　_
　　　　　　　　　　　　　　　　　　　InStr(v(i,　n),　"Total")　=　0　And　_
　　　　　　　　　　　　　　　　　　　LenB(v(i,　n))　>　0　Then　_
　　　　　　　　　　　　　　　　　　　ch　=　True
　　　　　　　　　　　　Next

　　　　　　　　　　　　If　ch　=　True　Then
　　　　　　　　　　　　　　　j　=　j　+　1
　　　　　　　　　　　　　　　For　m　=　1　To　16
　　　　　　　　　　　　　　　　　　　vv(j,　m)　=　v(i,　m)
　　　　　　　　　　　　　　　Next
　　　　　　　　　　　　　　　ch　=　False
　　　　　　　　　　　　End　If
　　　　　　　　Next
　　　　　　　　.Range(.Range("A2"),　.Cells(Rows.Count,　1).End(xlUp)　_
　　　　　　　　.Resize(,　16)).ClearContents
　　　　　　　　.Range("A2").Resize(j,　16).Value　=　vv
　　　　　　　　.Range("A2").Resize(j,　16).Sort　Key1:=.Range("A2"),　_
　　　　　　　　　Order1:=xlAscending,　Header:=xlGuess,　OrderCustom:=1,　_
　　　　　　　　　MatchCase:=False,　Orientation:=xlTopToBottom,　_
　　　　　　　　　SortMethod:=xlPinYin,　DataOption1:=xlSortNormal
　　　End　With

　　　For　i　=　1　To　j
　　　　　　　With　Worksheets(vv(i,　1))
　　　　　　　　　　　　If　.Range("A1").Value　=　""　Then
　　　　　　　　　　　　　　　Set　r　=　.Range("A1")
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　Set　r　=　.Range("A"　&　Rows.Count)　_
　　　　　　　　　　　　　　　　　　　　　　　.End(xlUp).Offset(1)
　　　　　　　　　　　　End　If

　　　　　　　　　　　　For　m　=　1　To　16
　　　　　　　　　　　　　　　　r.Offset(,　m　-　1).Value　=　vv(i,　m)
　　　　　　　　　　　　Next

　　　　　　　End　With
　　　Next
　　　Set　r　=　Nothing
　　　Erase　v,　vv
　End　Sub
試してみて下さい。

お礼

試してみました。

With Worksheets(vv(i, 1))
が部分で黄色が出ます。

回答No.15

n-jun

>Dim　n　As　Integer,　ch　As　Boolean　'変数の宣言追加
は追加されてますか？

>シートに変化がありません。
データがもとのまま何も変わらない？
エラーも出ないのでしょうか？

ch　=　False : Debug.Print vv(i,1)
で配列にデータが入っているか（Ａ列）とか、確認していくしかないです。
実際のデータがないので、こちらでは検証が出来ないです。

>If InStr(v(i, n), "total") = 0 And _
>InStr(v(i, n), "Total") = 0 And _LenB(v(i, n)) > 0 Then _
If InStr(v(i, n), "total") = 0 And _
InStr(v(i, n), "Total") = 0 And _
LenB(v(i, n)) > 0 Then _
コピペミス？

お礼

ご連絡遅くなり申し訳ございません。
あれから、何度も試しているのですが、何が悪いのか全くわからないのですがうまくいきません・・・

なので、下記のように作業工程を変えてみようと思いまして。
ダウンロードしたファイルからAuto　Filterでtotalを除き、コピーしてマクロを書き込んでいるシートに貼り付ける。
その後、Do　loopでコラムAの通貨毎にチェックし、各々の同じ名前のページに貼り付ける。

そこで、マクロを組んでみたのですが、loopのつなぎ目がわかりません・・・
もう一度教えていただけないでしょうか。沢山教えていただいたのに成功せず、あげく違う方法をお伺いしてすみません。

Dim MyStr As String
Dim i As Long
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

i = 1
Do Until Cells(datagyo, 2) = ""
If Cells(datagyo, 1) = "AUD" Then
Range(Cells(datagyo, 2), Cells(datagyo, 16)).Select
Selection.Copy
Sheets("AUD").Select
Cells(i + 1, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Application.CutCopyMode = False
i = i + 1
End If

If Cells(datagyo, 1) = "EUR" Then
Range(Cells(datagyo, 2), Cells(datagyo, 16)).Select
Selection.Copy
Sheets("EUR").Select
Cells(i + 1, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Application.CutCopyMode = False
i = i + 1

End If
datagyo = datagyo + 1
Loop

だと最初からエラーで。。。