度々すみません。
わからない事がいくつか出てきてしまって。どなたかご教示いただけると嬉しいです。
今は手作業で以下のような作業をしております。
データ元のシート(以下(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ベストアンサー
- 回答日時:
>12枚のデータ元のページのうち、データがあるもののみtotalに貼り付けたいのですが
>何か使えるマクロはありますでしょうか。
http://okwave.jp/qa4200665.html
のANo.4での回答に類似。
各シートのセルA1にデータがある場合コピペする。
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
- 回答日時:
>ここでいうデータは
>Set ws1 = Worksheets("Summary") '纏めるシート
>と同じシート名ですよね?
>見えにくいスペースなどあるのかと思い、再度Re nameして試みてみましたが同じ結果でした。
With Worksheets("data")
ワークシート"data"の事です。
纏める時にワークシート"Summary"と ワークシート"data"を除外したい
と言う事になります。
間違えてSummaryを記入していました。
今、訂正し試したところ、うまくいきました!
n-junさん、長い間、本当にありがとうございました。何回もつきあっていただけて、こんないい人いるんだなと本当に感謝しております。
何度言っても言い足りませんが、長期間にわたってありがとうございました!!
No.24
- 回答日時:
>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
- 回答日時:
>でも、データを集結した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
- 回答日時:
>三個を連続でさせたかったのですが、どうもうまく回らず別々にしました。
>三個目のマクロが全く起動しません。エラーもなく何も変化なし。
こちらで検証した範囲では問題ないのですが、実際のデータとBookで
デバッグをしていかないと難しいです。
起動しないとは、実行しても集計がまとまらない?と言う事であれば、
必要なシートを選択しているのか(For Each~Next)、
データ範囲を取得できているのか(r2のアドレス)等々の確認をしていくしかないです。
この回答への補足
自分で書いていて「うん??」と気付きました。
マクロ2がうまくいっていたようでいっていなかったみたいです。
修正したら、無事出来ました!
でも、データを集結したsummryシートが何故か全通貨貼り付け終わった次の行に【Sub try2()の中のWith Worksheets("data")シートの】の内容をコピ-してしまっています。
集計が始まらない(空回りしているみたいに)というか各々通貨シートにもコピーが始まらないのです。
デバックすら出ないのです。。。
もうちょっと試してみますね。
う~ん。。。なんででしょう・・・
No.21
- 回答日時:
>集結するシートの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とエラーが出るようになりました。
ここについては、未だ経験のないエラー(?)なので、ちょっとわかりません。
ただ、上記追加をお願いしたコードが悪さをしているのかな?と
思いますので、削除してみて下さい。
この回答への補足
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
三個を連続でさせたかったのですが、どうもうまく回らず別々にしました。三個目のマクロが全く起動しません。エラーもなく何も変化なし。
(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)
No.20
- 回答日時:
>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
値のみをペーストすることと、値を代入することは同じはずですが。
例えばセルB1の値をA1に入れたい場合、
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
- 回答日時:
>(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
- 回答日時:
>With Worksheets(vv(i, 1))
>が部分で黄色が出ます。
コピペしたデータから余分なデータは削除し、その後に残るA2以下の
A列のデータと同じ名前の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
- 回答日時:
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
試してみて下さい。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) 記録マクロのみでできますか? 7 2022/08/07 20:38
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 3 2023/02/28 01:13
- Excel(エクセル) 【困っています】VBA 追加処理の記述を教えてください。 1 2022/08/25 22:54
- Excel(エクセル) エクセルのマクロでコピー後の貼り付け先を毎回指定したところにしたい 5 2022/08/12 10:47
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 1 2023/02/27 22:21
- Excel(エクセル) VBA ふたつの同じ様式シートのセルをコピーしたい 2 2023/03/08 15:28
- Excel(エクセル) エクセルのマクロについて教えてください。 1 2023/02/25 11:55
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2023/08/03 11:27
- Excel(エクセル) フォルダ内の全ブックのシート名を変更したい 7 2022/09/22 21:34
- Excel(エクセル) エクセルのマクロについて教えてください。 3 2023/02/07 14:47
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
複数シートからデータを拾って...
-
エクセルファイルのシート毎の容量
-
Excelでシートの違うデータでグ...
-
excelの不要な行の削除ができな...
-
シート削除して同名シート追加...
-
Excelで日付変更ごとに、自動的...
-
EXCELで2つのファイルから重複...
-
VBAで CTRL+HOMEの位置へ移動...
-
エクセルで名簿を50音で切り分ける
-
他のシートの一番下の行データ...
-
Excelファイルの容量が異常に大...
-
半導体熱抵抗の測定方法について
-
Excelで複数シートの内容を一覧...
-
エクセルのデータ振り分け方法...
-
EXCEL VBAで作成したス...
-
【エクセルマクロ】複数シート...
-
Excel 売上管理シートに入力し...
-
エクセル マクロ "特定の日付...
-
【マクロ】同じフォルダ内にあ...
-
オートフィルタで抽出したデー...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルファイルのシート毎の容量
-
複数シートからデータを拾って...
-
Excelでシートの違うデータでグ...
-
シート削除して同名シート追加...
-
Excelで日付変更ごとに、自動的...
-
excelの不要な行の削除ができな...
-
VBAで CTRL+HOMEの位置へ移動...
-
(VBAにて)日付でデータを抽出す...
-
EXCELで2つのファイルから重複...
-
他のシートの一番下の行データ...
-
エクセルのカメラ機能について
-
トランジスタの選び方
-
別々のシートの表をピボットテ...
-
エクセル 縦に長い表の印刷時...
-
EXCEL 複数行のデータを1行にま...
-
【エクセル」 特定のセルで条件...
-
オートフィルタで抽出したデー...
-
Excel 売上管理シートに入力し...
-
エクセル VBA VLOOKUP
-
EXCEL の表を一行ずつシートに...
おすすめ情報