[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『最終行まで取得して、コピペを繰り返す （ペーストセルは固定）』（SARA）
こんばんは。あらゆるものをひろって、記憶しながら行き詰っています。
見ずらい形になっておりすみません。。今していることはアナログですm(__)m
sheet2のデータをsheet1に貼り付けて、PDFにします。
現在は、
sheet2のA列2行目の番号をコピーして、
sheet1値でE1に貼り付け
sheet2のF列2行目をコピーして
sheet1のB1に貼り付けて、PDFにして保存します。
名前は、お礼の名前_番号.pdf希望です。
これが10枚くらいだったらいいのですが、50枚となると辛くお力をお貸しいただけないでしょうか・・<m(__)m>
●（sheet1）letterシート・・・PDFを出力するデータ
B1=お礼の名前
E1=番号
↑文章が書いてあり、張り付けるセルは固定です。
●（sheet2）○月〇日の参照データ・・・データが詰まっている
A B C D E F G
1 番号 継続 待機 備考 備考2 お礼の名前 対応
2 P511 マナ
3 P501 カナ
4 P101 モナ
5 P001 ミナ
6 P051 サナ
↑番号が重複することはありません。
一旦自分でどんな形にしたいのか考えてみました。
2行目をコピーするというのは奇跡的に成功しました。
これをループしたいのですが、私の知能ではたどり着けそうになく何か方法があれば教えていただきたいです。
なんとなく、最終行を取得して、+1のような感じで、できないでしょうか。。。
n = Cells(Rows.Count, "A").End(xlUp).Row
下記作業を繰り返したいです。
Cells.Find("お礼の名前").Select
Selection.Offset(1, 0).Copy
For Each mysheet In Worksheets If mysheet.Name Like "*letter*" Then mysheet.Activate Exit For End If Next
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
For Each mysheet In Worksheets If mysheet.Name Like "*○月〇日の参照データ*" Then mysheet.Activate Exit For End If Next
Cells.Find("番号").Select
Selection.Offset(1, 0).Copy
For Each mysheet In Worksheets If mysheet.Name Like "*letter*" Then mysheet.Activate Exit For End If Next
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
"\pass\" & Range("B1").Value & "_" & Range("E1").Value & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
---------------------------------------------
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
こんばんは ＾＾ 回答ではありません 気が付いた点だけで済みません。 処理対象のワークシート【"*○月〇日の参照データ*" 】は何枚あるのでしょうか たくさんアドバイス、回答が有ると良いですね。でわでわ。。。m(_ _)m （隠居じーさん） 2020/01/17(金) 20:00
ご質問お気づきありがとうございます( ;∀;)また暖かい心遣いありがとうございます。
【"*○月〇日の参照データ*" 】は1枚です！
その日開くと当日の日付がはいります。【"*参照データ*" 】だけでよかったかもしれません。。
よろしくお願いします。
（SARA） 2020/01/17(金) 20:12
こんばんは ＾＾ 様々な方法があろうかと存じますが 一案です。ファイルパス等、解りませんので、ＰＤＦ出力は、印刷プレビューに 置き換えております。外していましたらお許しを。m(_ _)m
Option Explicit
Sub OneInstance()
Dim Base
Dim i As Long
Dim Ws1 As Worksheet
Dim WsS As Worksheet
For i = Worksheets.Count To 1 Step -1
Select Case True
Case Worksheets(i).Name Like "*letter*"
Set Ws1 = Worksheets(i)
Case Worksheets(i).Name Like "*参照データ*"
Set WsS = Worksheets(i)
End Select
Next
With WsS
Base = .Cells(1).CurrentRegion
End With
With Ws1
For i = 2 To UBound(Base, 1)
.Range("B1") = Base(i, 6)
.Range("E1") = Base(i, 1)
.PrintPreview
Next
End With
Erase Base
Set Ws1 = Nothing
Set WsS = Nothing
End Sub
（隠居じーさん） 2020/01/17(金) 20:45
こんばんは！
隠居じーさん さまから素敵な回答がついてますけど、、書いていたのでUpします。
以下
とても動くものではないですけど、、ちょっと書いてみました。
書いていて思ったことは、 1.Select とか Activate は使わないでコードを書くこと 2.Rangeなどの前には必ずSheet名を指定すること 3.Find で検索した時もそうですけど、、必ずしもあるとは限りませんので ヒットしなかった場合のことも記述すること(よく私も抜けます＿|￣|○）
で、いきなりは難しそうなので先ずは日本語で、、それもご自身の言葉でストーリーを書くこと
そんなことを繰り返していくうちに自然とコードなんてのは書けるようになります。(多分(^^;弱気）
参考にもならないでしょうけど、、良かったら参考にしてみて下さい。
では、、では、、また、、
Option Explicit
Sub kk()
'変数を一つ宣言して
Dim ws As Worksheet
'Sheet2をFindで検索
With Sheets("Sheet2")
.Cells.Find("お礼の名前").Offset(1, 0).Copy
End With
'*letter* シートを wsにSetして
For Each mysheet In Worksheets
If mysheet.Name Like "*letter*" Then
Set ws = mysheet
Exit For
End If
Next
'wsがあれば実行なければ終了
If Not ws Is Nothing Then
ws.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Exit Sub
End If
'*○月〇日の参照データ* シートをwsにSetして
For Each mysheet In Worksheets
If mysheet.Name Like "*○月〇日の参照データ*" Then
Set ws = mysheet
Exit For
End If
Next
'Sheet2の番号の一つ下をコピー
With Sheets("Sheet2")
.Cells.Find("番号").Offset(1, 0).Copy
End With
'*letter*シートをwsにSetして
For Each mysheet In Worksheets
If mysheet.Name Like "*letter*" Then
Set ws = mysheet
Exit For
End If
Next
'wsがあれば実行なければ終了
If Not ws Is Nothing Then
.Range("E1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Exit Sub
End If
'wsシートをPdfに出力
With ws
.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"\pass\" & .Range("B1").Value & "_" & .Range("E1").Value & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End With
End Sub
（SoulMan） 2020/01/17(金) 20:50
.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"\pass\" & .Range("B1").Value & "_" & .Range("E1").Value & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
まず、形が全く違うことに驚きました。
そして、いただいた最初コメントいただきました隠居じーさんのマクロをぽちっと入れまして
実行したら、何度プレビュー×押しても消えない(;´･ω･)となったのですが、それはプレビューだからということですね('◇')ゞ！！←プレビューって書いてくださっているのに、理解めっちゃ遅かったです。
SoulMan様
ありがとうございます！正直宣言はあまりわかりませんでした(m´・ω・｀)m
こちらも実行して、少しとまりましたので、デバッグさんが見つけてくれたところ追加してみましたが、私ではわかりませんでしたm(__)m
シート名を記載することなど、メモつきでありがとうございます。
'wsがあれば実行なければ終了 など、絶対いると思うので、頂戴させていただきます( ;∀;)
目の前にこんな素晴らしい方がいらっしゃったらなといつも思います( ;∀;)
最近IFをようやく理解したかな、理解できたかなという感じで。。
ほんとにつなぎ合わせているので、マクロ理解者とは程遠いです。
以前は、エクセルにマクロ記憶があるということを知り感激して、スクロールしすぎてなぜか入りきらないエラーみたいなのが出てしまったので、
そこから少しずつ、何かコードらしきものを書くんだ！となっていますが、なんか急に難しいとなっています(*´▽｀*)
隠居じーさんさま、SoulManさま、
ありがとうございましたm(__)m
（SARA） 2020/01/17(金) 21:37
■１
とりあえず動いているとのことですが
「〜Activate」とか「〜Select」していて、Selection○○やActive○○ありきのコードになっているので、まずここを改善してみましょう。
■２
「Findメソッド」を使っておられますが、Findメソッドは目的のセルが見つからなかった場合、「Nothing」という特殊な値を返します。
http://officetanaka.net/excel/vba/cell/cell11.htm
「Nothing」はセルとしては扱えませんので、「Select、Offset、Copy」なども当然出来ません。
したがって、「Nothing」じゃないときだけ処理をするというようにする必要があります。
さらに、Findメソッドは通常操作の検索に相当しますが、いくつかの引数（オプションみたいなもの）で記述を省略した場合、前回値が承継されるものがあります。（前回とは、通常の検索、Findメソッドの実行どちらも対象になります）
したがって、仮にキーワードが正しくても、検索に失敗する可能性があります。
https://www.moug.net/tech/exvba/0150111.html
したがって、Findメソッドを使用されるなら
(1) 引数はちゃんと書く (2) 見つかった時のみ(Nothingじゃなかった時のみ）処理されるようなコードにする
というところに注意したほうがよいです。
■３
PasteSpecialメソッドの引数について、規定値のものは省略が可能です。
■４
コードは、sub〜end sub までが一塊なので、どうせ提示するなら全体を見せたほうがよいとおもいます。
（もちろん個人情報などは隠して（適当なものに変えて）ＯＫです）
■５
＞【"*○月〇日の参照データ*" 】は1枚です！
全シートを巡回して、目的のシートを探している部分があります。
この方法でも間違いではありませんが、別の方法もあります。
■６
ということで、テストしてないですが、もともとのコードを整理・修正するとこんな感じ。（ループ処理にはしていません）
Sub 整理()
Dim srcSH As Worksheet
Dim 発見セル As Range
Dim お礼の名前 As String, 番号 As String
Dim シート名 As String
Const フォルダパス As String = "C:\work\"
お礼の名前 = "マナ"
番号 = "P511"
シート名 = "○月〇日の参照データ"
'▼データシートを特定
On Error Resume Next
Set srcSH = Worksheets(シート名)
On Error GoTo 0
If srcSH Is Nothing Then
MsgBox "【" & シート名 & "】が見つかりません" & vbkf & "処理を中止します"
Exit Sub
End If
With srcSH
'▼Findメソッドで検索
Set 発見セル = .Columns("F").Find(What:=お礼の名前, LookIn:=xlValues, LookAt:=xlWhole)
'▼見つかったときだけ処理
If Not 発見セル Is Nothing Then
発見セル.Copy
Worksheet("letter").Range("B1").PasteSpecial Paste:=xlPasteValues
End If
'▼考え方は上に同じ
Set 発見セル = .Columns("B").Find(What:=お礼の名前, LookIn:=xlValues, LookAt:=xlWhole)
If Not 発見セル Is Nothing Then
発見セル.Copy
Worksheet("letter").Range("E1").PasteSpecial Paste:=xlPasteValues
End If
End With
Worksheet("letter").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=フォルダパス & お礼の名前 & "_" & 番号 & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
■７
ループ処理したいということですが、６のコードをステップ実行して、どの命令がなにをやっているのか研究してみて、どの部分が次々と入れ替わったらよいのか考えてみてはどうでしょうか？
■８
ここまで書いておいてなんですが、「番号が重複することはありません。」なので、FINDメソッドで【検索】するんじゃなくて、フィルタオプションやオートフィルタなどで【抽出】するとか、【検索】などせずに、２〜最終行まで順番に処理すればいいだけのような気がします。
（もこな２ ） 2020/01/18(土) 13:32
推測があってるとすると、こんな感じ。
Sub 実験()
Dim srcSH As Worksheet
Dim シート名 As String
Dim 行 As Long
Const フォルダパス As String = "C:\work\"
シート名 = Format(Date, "mm月dd日の参照データ")
'▼データシートを特定
On Error Resume Next
Set srcSH = Worksheets(シート名)
On Error GoTo 0
If srcSH Is Nothing Then
MsgBox "【" & シート名 & "】が見つかりません" & vbLf & "処理を中止します"
Exit Sub
End If
'２〜A列最終行までをループ処理
With Worksheets("letter")
For 行 = 2 To srcSH.Cells(srcSH.Rows.Count, "A").End(xlUp).Row
.Range("B1").Value = srcSH.Cells(行, "F").Value
.Range("E1").Value = srcSH.Cells(行, "A").Value
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=フォルダパス & .Range("B1").Value & "_" & .Range("E1").Value & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Next 行
End With
End Sub
（もこな２ ） 2020/01/18(土) 13:54
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.