エクセルマクロ 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.14

n-jun

>一回目のsortが終了したところまでマクロ、書けました！
>(2)コラムAを基準にsortし、通貨毎に並び変え。
ソートはデータを貼り付けたあとに行なうとして、

　　　Dim　n　As　Integer,　ch　As　Boolean　'変数の宣言追加
　　　'Set～までは同じ

　　　ch　=　False
　　　With　wb1.Worksheets("Sheet1")　'ワークシート名変更
　　　　　　　　v　=　.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(.[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　wb2.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
　　　'以降は同じ

>(3)並び変えたデータを同じ名前の各々のシートに貼り付け。この際も並んでいる通貨の順番とシートの順が同じではない。
>（データ元にはAUD・JPYと並んでいるが、シートはAUD、USD、JPYという順で存在している等）
データの順番とシートの順番は関連していないです。
あくまでＡ列の値をシート名としている場合に転記を行ないます。

お礼

Dim wb1 As Workbook
Dim wb2 As Workbook
Dim r As Range
Dim i As Long, j As Long
Dim m As Integer
Dim v, vv

Workbooks.OpenText Filename:="R:\CMPC\Treasury P&L\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
Set wb1 = ActiveWorkbook
Set wb2 = ThisWorkbook
ch = False
With wb1.Worksheets("trade to mark")
v = .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　　以下続く

ですとシートに変化がありません。
転記元（sort等の作業を行うシート）のシートのページ名前はあっています。。。

回答No.13

n-jun

>でまわしましたがデータに何の変化もありません。
>With wb1.Worksheets("trade to mark")
>Workbooks.OpenText Filename:="R:\CMPC\P&L\P&L\Treas_Trade_to_mark"
ワークシートの名前あってます？
多分"Treas_Trade_to_mark"が名前になると思いますし、
エラーがでませんか？
別段名前で指定することもないと思いますけど。

回答No.12

n-jun

>質問なのですが、コラムはA～Pまであり、コラムAからPまでtotalな行もあればコラムBのみがtotal、コラムHのみTotalという行もあります。
>このマクロでは、そういった場合もコラムA～Pのどこかしらにtotalが一個でも含まれている場合も削除してくれるのでしょうか？
このマクロはＡ列しか判断していませんので、Ｂ列より右に該当文字があっても（Ａ列にはない場合）、
削除の対象になりません。

>コラムAの通過の種類が毎回きまっていない場合は適当に×10や20にすればいいのですよね？
通貨の事ですか？
削除対象はＡ列に"total"と"Total"があった場合、削除（除外）してます。
他の通貨表示があっても上記単語を含まなく、且つ振り分けるシートが
存在していれば、そのままで実行できます。

Ａ列以外に削除対象が存在し、且つＡ列に存在しない場合に対処するなら、
方法を変更しなければなりません。（と思います。）

お礼

＞Ａ列以外に削除対象が存在し、且つＡ列に存在しない場合

もあります。

先に言わなくてすみません。

補足

一回目のsortが終了したところまでマクロ、書けました！
sort後の今のシートの状況は
全部でデータが300行強あり、そのうち250行目以降はA～Pのどこかしらにtotalが入っています。250行目までは通過はバラバラで並んでいます。
この後の作業として
(1)250行目以降のtotal行を削除。（何行目からtotalが始まるかは毎回違う）
(2)コラムAを基準にsortし、通貨毎に並び変え。
(3)並び変えたデータを同じ名前の各々のシートに貼り付け。この際も並んでいる通貨の順番とシートの順が同じではない。（データ元にはAUD・JPYと並んでいるが、シートはAUD、USD、JPYという順で存在している等）

(2)は自分で出来ますので、(1)と(3)のアドバイスいただけたら助かります。

本当にご迷惑をおかけしてすみません。

回答No.11

n-jun

取り敢えず気になるのは二つ
・Worksheets("1")と言うのはシート名が"１"と言う事。
　私が提示したのは一番左のシートと言う事で
　Worksheets(1)　←左から１番目という意味。
・セルＨ２の説明がない。
　あくまでＡ列からＥ列しかないと思っての回答です。
　並べ替えが"total"と"Total"を削除する前に必要かどうかで
　決まりますが、削除したいのであれば別に事前の並べ替えは
　必要ないと思います。

"Total"の行を残したいのであれば、
If InStr(v(i, 1), "total") = 0 And _
　　　InStr(v(i, 1), "Total") = 0 Then
を
If InStr(v(i, 1), "total") = 0 Then
として下さい。

vv(j, m) = v(i, m)　の部分を何回も回ると言うのはＦ８の事でしょうか？
これはデータ行数に比例して繰り返しますので、
total & Totalを含まない行数×５回繰り返します。

'With wb1.Worksheets(1)
' Active.Range("A1").Select
' ActiveSheet.Range Range("A1").Select
' ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select.Sort Key1:=Range("H2"), _
' Order1:=xlAscending, Header:= _
' xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
' SortMethod:=xlPinYin, DataOption1:=xlSortNormal
' ActiveWindow.SmallScroll Down:=138
'End With
ここの必要性について補足願います。

お礼

必要性についてという事なのですが
＞これはデータ行数に比例して繰り返しますので、
total & Totalを含まない行数×５回繰り返します。

という文章でやっとわかりました。n-junさんのマクロにはtotal行の削除より前のマクロと、各々のシートへの貼り付けの部分はn-junさんのマクロにはまだ含まれていないのかなと思っておりました。。。
このマクロはsortする事なくtotalを含む行を削除するという事ですね。
質問なのですが、コラムはA～Pまであり、コラムAからPまでtotalな行もあればコラムBのみがtotal、コラムHのみTotalという行もあります。
このマクロでは、そういった場合もコラムA～Pのどこかしらにtotalが一個でも含まれている場合も削除してくれるのでしょうか？
（コラムAの通過の種類が毎回きまっていない場合は適当に×10や20にすればいいのですよね？）

私のマクロを削除し、

With wb1.Worksheets("trade to mark")
v = .Range(.[A2], .Cells(Rows.Count, 1) _
.End(xlUp).Resize(, 5)).Value
ReDim vv(1 To UBound(v, 1), 1 To 5)
For i = 1 To UBound(v, 1)
If InStr(v(i, 1), "total") = 0 And _
InStr(v(i, 1), "Total") = 0 Then
j = j + 1
For m = 1 To 5
vv(j, m) = v(i, m)
Next
End If
Next
.Range(.[A2], .Cells(Rows.Count, 1).End(xlUp) _
.Resize(, 5)).ClearContents
.Range("A2").Resize(j, 5).Value = vv
End With
でまわしましたがデータに何の変化もありません。

回答No.10

n-jun

>何回も回ってしまい、且つ、どうもシート上でのデータは何も変わっておりません。。
取り敢えずコードを全部提示してもらえますか。

お礼

Sub Macro12()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim r As Range
Dim i As Long, j As Long
Dim m As Integer
Dim v, vv
Workbooks.OpenText Filename:="R:\CMPC\P&L\P&L\Treas_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
Set wb1 = ActiveWorkbook
　 Set wb2 = ThisWorkbook
With wb1.Worksheets("1")
Active.Range("A1").Select
ActiveSheet.Range Range("A1").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
ActiveWindow.SmallScroll Down:=138
With wb1.Worksheets("Sheet1")
v = .Range(.[A2], .Cells(Rows.Count, 1) _
.End(xlUp).Resize(, 5)).Value
ReDim vv(1 To UBound(v, 1), 1 To 5)
For i = 1 To UBound(v, 1)
If InStr(v(i, 1), "total") = 0 And _
InStr(v(i, 1), "Total") = 0 Then
j = j + 1
For m = 1 To 5
vv(j, m) = v(i, m)
Next

補足

続きです。

End If
Next
.Range(.[A2], .Cells(Rows.Count, 1).End(xlUp) _
.Resize(, 5)).ClearContents
.Range("A2").Resize(j, 5).Value = vv
End With
For i = 1 To j
With wb2.Worksheets(vv(i, 1))
If .Range("A1") = "" Then
Set r = .Range("A1") Else
Set r = .Range("A" & Rows.Count) _.End(xlUp).Offset(1) End If
For m = 1 To 5
r.Offset(, m - 1).Value = vv(i, m)
Next
End With
Next
Set r = Nothing
Erase v, vv

End Sub

回答No.9

n-jun

>With wb1.ActiveWorksheets("1")
>の行でエラーです。
>ActiveWorksheetsを変えてみたり、（”1”）をRenameした名前に
>置き換えたりしたのですがダメでした。
ActiveSheetとは現在アクティブな状態（通常Excelで見える・編集できる状態）
のSheetのことですから、複数系sはつきませんし名前もつかないはずです。

>Workbooks.OpenText
ここで別にBookが開いてActiveな状態になっていて、且つSheetは１枚
のはずですから、
With　wb1.Worksheets(1)
で良いはずですが？
それで無理なら、
With　wb1.Sheets(1)　
かな？

お礼

sort後にtotal行を削除、各々のシートに貼り付けとしたいので
作成していただいたのがマクロがtotalの削除と各々への貼り付け部分でしたので、その前にsortのマクロを入れ下記にしました。
Sub Macro12()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim r As Range
Dim i As Long, j As Long
Dim m As Integer
Dim v, vv
Workbooks.OpenText Filename:="C:\TD 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
Set wb1 = ActiveWorkbook
Set wb2 = ThisWorkbook
With wb1.Worksheets(1)
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
v = .Range(.[A2], .Cells(Rows.Count, 1) _
.End(xlUp).Resize(, 5)).Value
ReDim vv(1 To UBound(v, 1), 1 To 5)　　以下続く

しかし、Range("A1").Select部分でエラーです。
その為、自分で作成したsort部分のマクロを削除しn-junさんのマクロをそのままrunさせたのですが、
v = .Range(.[A2], .Cells(Rows.Count, 1) _.End(xlUp).Resize(, 5)).Value　　～
vv(j, m) = v(i, m)　Next
部分を何回も回ってしまい、且つ、どうもシート上でのデータは何も変わっておりません。。n-junさん、本当に問題ばかりですみません。

回答No.8

n-jun

>Sub　Macro（）のところからF8をすると、
提示されているのはMacro２ですけど、古いのが残っているとか？

Ｆ８によるステップ実行はやった事ないので詳しくはないです。
ＯＳ再起動とかでしょうか。。。

お礼

マクロを何度も書き換えているうちに途中のEnd　Withが消えていたようです。すみませんでした。

マクロですが、
Set wb1 = ActiveWorkbook
Set wb2 = ThisWorkbook

With wb1.ActiveWorksheets("1")
v = .Range(.[A2], .Cells(Rows.Count, 1) _
.End(xlUp).Resize(, 5)).Value
ReDim vv(1 To UBound(v, 1), 1 To 5)
For i = 1 To UBound(v, 1)
If InStr(v(i, 1), "total") = 0 And _
InStr(v(i, 1), "Total") = 0 Then
j = j + 1
For m = 1 To 5
vv(j, m) = v(i, m)
Next
End If　　以下続く。。。

で走らせたところ、
With wb1.ActiveWorksheets("1")
の行でエラーです。
ActiveWorksheetsを変えてみたり、（”1”）をRenameした名前に置き換えたりしたのですがダメでした。

回答No.7

n-jun

ANo.6です。

>転記先がマクロ sample TD Trade to Mark。
>マクロの書き込みをしているのも同じくマクロ sample TD Trade to Mark。
私は転記もとにコードを書いていると思って回答してましたので、
何となく理解できました。

Set wb1 = Activeworkbook
Set wb2 = ThisWorkbook
になると思います。

>ChDir "R:\"
はいらないと思いますよ。

お礼

n-jinさん、
私もそうなのかも先程気付いて、何回もやり直していたのですが、
F8でマクロを一行づつ確認していく作業が出来ないのですが、私、何かやらかしてしまったんでしょうか？
Sub　Macro（）のところからF8をすると、最後のEnd　Subに飛び、Expected End Withというメッセージが出ます。

最後のマクロを応急で変えてみたり書き込み先を変えてみたりしているのですが、同じシートに書き込んでいる他のマクロも同じようになり動かなくなりました。

本当に次から次にすみません・・・

回答No.6

n-jun

ANo.5です。

>で走らせてみたところ、
>Set wb1 = ThisWorkbookでSubscript　out　of　range
>とエラーが出ます。（シートは開くのですが）何が理由なのでしょうか。。。
コードを書いている自Bookを指定させていたのですが、
>Workbooks.OpenText
ここで別にBookが開いているのでは？と思います。
OpenText メソッド　のヘルプには、
「テキスト ファイルを 1 枚のシートとして、それを含む新しいブックを開きます。」
とありますので。

ThisWorkbook　⇒　ActiveWorkbook　かな？

お礼

何度もありがとうございます。でも、まだダメなので、まだお世話になってしまうのですが・・・すみません！！

アドバイス通りActiveWorkbookにしたら、次の行でエラーが出ます。

＞ここで別にBookが開いているのでは？と思います。
＞コードを書いている自Bookを指定させていたのですが
と以前の
＞Set　wb1　=　Workbooks("Book1.xls")　'転記もと
　Set　wb2　=　Workbooks("Book2.xls")　'転記先

なのですが、

他のシステムよりRドライブに落としたものがTD　trade　to　mark。
転記先がマクロ sample TD Trade to Mark。
マクロの書き込みをしているのも同じくマクロ sample TD Trade to Mark。

となると、転記元はTD　trade　to　mark、転記先はマクロ sample TD Trade to Markなのですが、
マクロの書き込みを転記先のシートにしている事からすると

＞Set wb1 = Activeworkbook
＞Set wb2 = Workbooks("マクロ sample TD Trade to Mark.xls")

のwb2 はWorkbooks("マクロ sample TD Trade to Mark.xls")ですよね？それともソコがそもそも違っていて

Set wb1 = ActiveWorkbook
Set wb2 = Workbooks("R:\CMPC\Treasury P&L\P&L\Treas_Trade_to_mark\マクロ sample TD Trade to Mark.xls")

のSet wb2 でエラーが出ているのですかね？

すみません・・・

回答No.5

n-jun

ANo.4です。

>マクロが走るかしてみたのですが
>Dim wb1 As Workbookのところで止まってしまいます。
エラーは何か出ていますか？
変数の宣言を始めに持っていっても同じでしょうか？

>Set wb1 = Workbooks("R:\CMP\Treasury P&L\P&L\Treas_Trade_to_mark\TD trade to mark")
>Set wb2 = Workbooks("R:\CMP\Treasury P&L\P&L\Treas_Trade_to_mark\マクロ sample TD Trade to Mark.xls")
コード自体をＣＳＶを取り込むブックに書いているのなら、
Set wb1 = Thisworkbook
Set wb2 = Workbooks("マクロ sample TD Trade to Mark.xls")
wb1は自Ｂｏｏｋ、wb2は事前に開いておく。

>With　wb1.Worksheets("Sheet1")
With　wb1.Worksheets(1)
一番左のシートなら１にしておく。

提示したコードはＣＳＶを取り込んだ状態から、"total","Total"を含まない行の
データを配列に入れてＡ２以下に表示するようにしています。
範囲はＡ列からＥ列の最終行までとしています。

お礼

おはようございます。

Sub Macro2()

Dim wb1 As Workbook
Dim wb2 As Workbook
Dim r As Range
Dim i As Long, j As Long
Dim m As Integer
Dim v, vv

ChDir "R:\"
Workbooks.OpenText Filename:="C:\TD 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

Set wb1 = ThisWorkbook
Set wb2 = Workbooks("R:\CMPC\Treasury P&L\P&L\Treas_Trade_to_mark\マクロ sample TD Trade to Mark.xls")

With wb1.Worksheets(1)

v = .Range(.[A2], .Cells(Rows.Count, 1) _
.End(xlUp).Resize(, 5)).Value
ReDim vv(1 To UBound(v, 1), 1 To 5)
For i = 1 To UBound(v, 1)
If InStr(v(i, 1), "total") = 0 And _
InStr(v(i, 1), "Total") = 0 Then
j = j + 1
For m = 1 To 5
vv(j, m) = v(i, m)
Next
End If
Next
.Range(.[A2], .Cells(Rows.Count, 1).End(xlUp) _
.Resize(, 5)).ClearContents
.Range("A2").Resize(j, 5).Value = vv
End With
For i = 1 To j
With wb2.Worksheets(vv(i, 1))
If .Range("A1") = "" Then
Set r = .Range("A1")
Else
Set r = .Range("A" & Rows.Count) _.End(xlUp).Offset(1)
End　if　For m = 1 To 5
r.Offset(, m - 1).Value = vv(i, m)
Next
End With
Next
Set r = Nothing
Erase v, vv
End Sub

で走らせてみたところ、
Set wb1 = ThisWorkbookでSubscript　out　of　rangeとエラーが出ます。（シートは開くのですが）何が理由なのでしょうか。。。