Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1616 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【73088】データをフォーマットに記述する はみりん 12/11/8(木) 0:16

【73089】Re:データをフォーマットに記述する ぶらっと 12/11/8(木) 8:18

【73090】Re:データをフォーマットに記述する UO3 12/11/8(木) 11:49

【73093】Re:データをフォーマットに記述する ぶりっと 12/11/9(金) 10:11

【73094】Re:データをフォーマットに記述する UO3 12/11/9(金) 12:25

【73095】Re:データをフォーマットに記述する ごんべえ 12/11/9(金) 13:15


	【73088】データをフォーマットに記述する

はみりん - 12/11/8(木) 0:16 -


	引用なし

	パスワード

かなり複雑な作業を突然頼まれて、自動化するように仰せつけられてしまい、困りあぐねています。概要は、「A.xls」に車の情報が書かれたリストがあり、そこから車名ごとにまとめ、別のExcelフォームに記述するというものです。作業内容は以下の通りです。 1. 「A.xls」のA列に「No.」、B列に「車名」、C列に「型式」、D列に「年」が入っているものとします。（例-1）　No.　　車名　　　　型式　　　　　年　　　　　1　　　●●WAGON　 H81W　　　　　01.10-06.08 　　　　　1　　　●●WAGON　 H82W　　　　　06.08- 　　　　　2　　　△△△　　　HA1W　　　　　05.12- 　　　　　3　　　■■■　　　N11W ,N21W※　91.06-93.03　　　　　　3　　　■■■　　　N11W ,N21W※　93.04-97.11　　　　　　3　　　■■■　　　N21WG　　　　 96.05-97.11 　　　　　:　　　　:　　　　　:　　　　　　　　: 2.　上記のデータで、No.順に車名ごとにまとめ、型式や年の情報をブック「B.xls」に記述します。ただし、　　1）B.xlsのシートの上3行には、項目見出しを入れる　　2）たとえページが変わっても常に上3行には項目見出しが表示されているようにする。（印刷タイトルではなく、直接シートに入力する）　　3）その3行の項目名の次に、No.順の「車名」を1行入れ、さらにその次の行から「型式」「年」のデータを「罫線付き」（普通の実線・格子）で貼り付ける　　4）※の部分のように、「同じ型式」の場合は、1つの枠とした罫線をつける　　5）同じ車名で、次のページにまたがる場合は、上3行の項目名の次行に車名を入れ、さらにその次から続きを貼り付ける　　　（例-2）＜1ページ目＞ ------------------------------------ ｜　　車両型式　　｜　　　　年　　　｜ ------------------------------------　　　　 ●●WAGON ------------------------------------ ｜ H81W　　　　　｜　01.10-06.08　｜ ------------------------------------　　　　｜ H82W　　　　　｜　06.08-　　　　｜ ------------------------------------　　　　 △△△ ------------------------------------ ｜ HA1W　　　　　｜　05.12-　　　　｜ ------------------------------------　　　　 ■■■ ------------------------------------ ｜ N11W ,N21W　　｜　91.06-93.03　｜｜ N11W ,N21W　　｜　93.04-97.11　｜ ------------------------------------ ｜ N21WG　　　　　｜　96.05-97.11　｜ ------------------------------------ 　　：　　　　　　　　　　：＜2ページ目＞ ------------------------------------ ｜　　車両型式　　｜　　　　年　　　｜ ------------------------------------　　　　 ■■■ ------------------------------------ ｜ N64WG　　　　　｜　99.10-02.08　｜ ------------------------------------ 　　：　　　　　　　　　　：というような作業を自動的に行いたいと思っております。各ページに貼り付ける上3行の項目名は、最初から用意しても構いませんが、できればその都度貼り付けるようにしたいです。ポイントは、同じ型式のときにまとめて枠で囲む、というところです。どのような発想したらよいか是非VBAの天才方にお伺いしたく投稿いたしました。何卒よろしくお願いいたします。　　　　


	【73089】Re:データをフォーマットに記述する

ぶらっと - 12/11/8(木) 8:18 -


	引用なし

	パスワード

▼はみりんさん
なぜ、VBAが出来ない人に、突然このような業務の指示が出されるのですか？
ちょっと、興味が有るので教えてください。

プログラムを作る部署にいるわけではないのですよね。


	【73090】Re:データをフォーマットに記述する

UO3 - 12/11/8(木) 11:49 -


	引用なし

	パスワード

▼はみりんさん：

こんにちは

私の存じ寄りの人間のＨＮが回答レスにありましたので、おっと彼は、ここにも。
と、開けてみましたが、違う人のようです。

まぁ、関係のない話は横に置き。
あぁ、そうそう。私は【普通の人】でして、ご要請のある【VBAの天才】ではありませんが。

この作業を行うことを指示されたけれども、手作業では面倒なので
ＶＢＡというもので何かできないだろうか？

そういうご相談でしょうかね？
はみりんさんはマクロ記録というものをご存知でしょうか。
もし、はみりんさんが、この作業を【エクセル上の手作業で】行うとすれば
それは、時間を掛ければできますよね。
その操作をマクロ記録すれば、そのままは使えませんが、基本としては利用できる
ｺｰﾄﾞが自動作成されます。

まず、そこまでやって、自動作成されたコードをアップしてみてはいかがですか？


	【73093】Re:データをフォーマットに記述する

ぶりっと - 12/11/9(金) 10:11 -


	引用なし

	パスワード

▼はみりんさんへ

Option Explicit
Sub TEST1()
Dim max_n As Integer
Dim m As Integer
Dim n As Integer
Dim k As Integer
Dim j As Integer
Dim n1 As Integer

　　max_n = Range("B" & Rows.Count).End(xlUp).Row
　　m = max_n
　　　　
　　Do While m > 2 '全体の繰り返し
　　　　
　　　　n = 0
　　　　Do While m > 2 '同じｸﾞﾙｰﾌﾟの繰り返し
　　　　　　If Cells(m - n, 2).Value = Cells(m - n, 2).Offset(-1, 0).Value Then
　　　　　　　　n = n + 1
　　　　　　Else
　　　　　　　　Exit Do
　　　　　　End If
　　　　Loop
　　　　　　
　　　　　　
　　　　'コピーや切取りの操作を取り消します
　　　　Application.CutCopyMode = False
　　　　'行を追加します
　　　　Range(m + 1 & ":" & m + 1 + n).Insert
　　
　　　　Range(Cells(m, 3), Cells(m - n, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous
　　　　'Range(Cells(m - n, 3), Cells(m - n, 4)).Borders(xlEdgeTop).LineStyle = xlContinuous
　　　　Range(Cells(m, 3), Cells(m - n, 4)).Borders(xlEdgeTop).LineStyle = xlContinuous
　　　　Range(Cells(m, 3), Cells(m - n, 4)).Borders(xlEdgeLeft).LineStyle = xlContinuous
　　　　Range(Cells(m, 3), Cells(m - n, 4)).Borders(xlEdgeRight).LineStyle = xlContinuous
　　　　If n = 0 Then
　　　　Else
　　　　　　Range(Cells(m, 3), Cells(m - n, 4)).Borders(xlInsideHorizontal).LineStyle = xlContinuous
　　　　End If
　　　　Range(Cells(m, 3), Cells(m - n, 4)).Borders(xlInsideVertical).LineStyle = xlContinuous
　　　　
　　　　Range(Cells(m, 3), Cells(m - n, 4)).Copy
　　　　Cells(m + 1, 2).PasteSpecial
　　　　Range(Cells(m, 3), Cells(m - n, 4)).Clear
　　　　'MsgBox m & n
　　　　If n = 0 Then
　　　　
　　　　Else
　　　　　　Range(m & ":" & m - n + 1).Delete
　　　　End If
　　　　
　　　　max_n = max_n - n - 1
　　　　m = max_n
　　Loop
　　

　　max_n = Range("B" & Rows.Count).End(xlUp).Row
　　m = max_n

　　j = 0
Do While j + 1 < m

　　If Cells(m - j, 2).Value = Cells(m - j, 2).Offset(-1, 0).Value Then
　　　　Range(Cells(m - j, 2), Cells(m - j - 1, 3)).Borders(xlInsideHorizontal).LineStyle = xlNone
　　　　'Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
　　　　j = j + 1
　　Else
　　　　j = j + 1
　　End If
　　'MsgBox m & j
Loop

'
　　Columns("A:A").Select
　　Selection.Delete Shift:=xlToLeft
　　Range("A1").Select
　　Selection.Delete Shift:=xlToLeft
　　Range("A1:B1").Borders(xlEdgeBottom).LineStyle = xlContinuous
　　Range("A1:B1").Borders(xlEdgeTop).LineStyle = xlContinuous
　　Range("A1:B1").Borders(xlEdgeLeft).LineStyle = xlContinuous
　　Range("A1:B1").Borders(xlEdgeRight).LineStyle = xlContinuous
　　　　

　　Dim 改ページ数 As Integer
　　Dim 改ページ位置行 As Integer
　　Dim 改ページ位置列 As Integer
　　Dim 改ページ位置行列番号
　　Dim i As Integer
　　Dim mm As Integer
　　
　　ActiveWindow.View = xlPageBreakPreview
　　改ページ数 = ActiveSheet.HPageBreaks.Count
　　
　　For i = 1 To 改ページ数
　　　　改ページ位置行 = ActiveSheet.HPageBreaks(i).Location.Row
　　　　改ページ位置列 = ActiveSheet.HPageBreaks(i).Location.Column
　　　　改ページ位置行列番号 = ActiveSheet.HPageBreaks(i).Location.Address
　　　　
　　　　mm = 0
　　　　If Cells(改ページ位置行, 2) = "" Then
　　　　　　Range(改ページ位置行 & ":" & 改ページ位置行).Insert
　　　　
　　　　　　Rows("1:1").Copy
　　　　　　Cells(改ページ位置行, 1).PasteSpecial
　　　　Else
　　　　　　For mm = 1 To 100
　　　　　　　　'mm = mm + 1
　　　　　　　　Cells(改ページ位置行, 2).Offset(-mm).Select
　　　　　　　　'MsgBox Cells(改ページ位置行, 2).Offset(-mm)
　　　　　　　　If Cells(改ページ位置行, 2).Offset(-mm) = "" Then
　　　　　　　　　　Range(改ページ位置行 - mm & ":" & 改ページ位置行).Insert
　　　　　　　　　　
　　　　　　　　
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　　　
　　　　　　Next
　　　　　　Rows("1:1").Copy
　　　　　　Cells(改ページ位置行, 1).PasteSpecial
　　　　End If
　　Next
　　'MsgBox 改ページ位置行
　　ActiveWindow.View = xlNormalView
End Sub


	【73094】Re:データをフォーマットに記述する

UO3 - 12/11/9(金) 12:25 -


	引用なし

	パスワード

▼はみりんさん：

私からもコード案を。

こんにちは

とりあえずのバージョンかも。

前提

・もしかしたら、A.xlsあるいはB.xlsがマクロブックなのかもしれませんが、
　一応、マクロブックがA.xlsやB.xlsではない場合も対応しています。
　（A.xlsやB.xlsがデータブックとしての扱いでもＯＫです）
・実行時にはA.xlsもB.xlsも、ともに開かれていることが前提です。
・A.xls、B.xlsの対象シート名が不明でしたので、どちらも "Sheet1"　にしてあります。
・A.xls の　対象シートのA列は定時サンプル通り、【正しく連番】がふられているということを
　前提にしています。つまり、A列データの最終行のセルの値が【ユニークな車名の数】ということです。
・B.xls の対象シートの先頭の３行（A1:B3")には、あらかじめ、任意の書式のタイトルが設定されている
　ということを前提にしています。
　（A,B列の４行目以降は、何かあってもなくても、コード内でクリアします）
・B.xls　の　対象シートの C列以降右側には何もないということを前提にしています。

なぜ「とりあえず」なのかといいますと、この種のリスト、エクセル上は、一見、いいのですが
実際に印刷すると、同じ車名データが１ページ分の行数以上にあった場合や、そうではなくても
前のページと泣き別れた場合、そのページに車名がなく、いきなり型式、年のデータが印刷されます。
なので、【こういう場合は、あらためてページの最初に車名をセットしてほしい】という要望が
【おうおうにして】でてくる？

Option Explicit

Dim PageCnt As Long
Dim pgbodies As Long
Dim pgLines As Long
Dim toSh As Worksheet
Dim headR As Range

Sub Sample()
　　Dim fromSh As Worksheet
　　Dim x As Long
　　Dim c As Range
　　Dim r As Range
　　
　　Dim totpages As Long
　　Dim totlines As Long
　　Dim netdatalines As Long
　　Dim cars As Long
　　Dim details As Long
　　Dim pgheads As Long
　　Dim oldcar As String
　　Dim newcar As String
　　
　　
　　Application.ScreenUpdating = False
　　
　　'モジュールレベル変数の初期化
　　PageCnt = 0
　　pgbodies = 0
　　pgLines = 0
　　
　　Set fromSh = Workbooks("A.xls").Sheets("Sheet1")　　'転記元シート。シート名は適切なものに
　　Set toSh = Workbooks("B.xls").Sheets("Sheet1")　　　'転記先シート。シート名は適切なものに
　　
　　If fromSh.Range("A2").Value <> 1 Then　　　　　　　 '念のため
　　　　MsgBox "転記可能データがありません"
　　　　Exit Sub
　　End If
　　
　　'転記先シートのページ情報取得等
　　With toSh
　　　　pgheads = 3
　　　　.Range("A1:B" & pgheads).Copy .Range("E1")　　　'３行のタイトル域の保存
　　　　Set headR = .Range("E1").CurrentRegion　　　　　'保存領域
　　　　.Columns("A:B").Clear　　　　　　　　　　　　　 '転記先領域の値、罫線、背景色等クリア
　　　　.ResetAllPageBreaks　　　　　　　　　　　　　　 '改行挿入があればクリア
　　　　.Cells(.Cells.Count).Value = 1　　　　　　　　　'ページ情報取得のためのダミー
　　　　pgLines = .HPageBreaks(1).Location.Row - 1　　　'自動改行ベースのページあたり行数
　　　　.Cells(.Cells.Count).Clear　　　　　　　　　　　'ダミーのクリア
　　　　pgbodies = pgLines - pgheads　　　　　　　　　　'ページあたりのヘッドを除くデータ行数
　　End With
　　
　　With fromSh
　　　　x = .Range("A" & .Rows.Count).End(xlUp).Row
　　　　cars = .Cells(x, "A").Value　　　　　　　　　　 '車名の種類の数
　　　　details = x - 1　　　　　　　　　　　　　　　　 '転記すべき型式、年　の行数
　　　　netdatalines = cars + details　　　　　　　　　 '転記シートにおけるヘッド以外の行数
　　　　'転記シートの必要ページ数
　　　　totpages = netdatalines \ pgbodies + IIf((netdatalines Mod pgbodies) = 0, 0, 1)
　　　　totlines = totpages * pgheads + netdatalines　　'転記シートの総行数
　　End With
　　
　　'★転記先にいったん罫線セット
　　With toSh.Range("A3:B" & totlines).Borders
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　End With
　　　　
　　'元データ抽出
　　With fromSh
　　　　For Each c In .Range("A2:A" & x)
　　　　　　newcar = c.Offset(, 1).Value
　　　　　　If newcar <> oldcar Then　　　　　　　　　　'車名ブレーク
　　　　　　　　PageOutput False, newcar　　　　　　　　'車名をセット
　　　　　　End If
　　　　　　PageOutput False, c.Offset(, 2).Value, c.Offset(, 3).Value '型式、年をセット
　　　　　　oldcar = newcar
　　　　Next
　　　　
　　　　PageOutput True　　 '無条件出力
　　　　　　
　　End With
　　
　　With toSh
　　　　headR.Clear　　　　　　　　'保存した３行タイトルをクリア
　　　　'★　車名行の罫線削除
　　　　Set r = .Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeBlanks)
　　　　r.Borders(xlEdgeLeft).LineStyle = xlNone
　　　　r.Borders(xlEdgeRight).LineStyle = xlNone
　　　　r.Borders(xlInsideVertical).LineStyle = xlNone
　　　　Application.Goto .Range("A1")
　　End With
　　
　　Application.ScreenUpdating = True
　　MsgBox "転記終了しました"
　　
End Sub

Private Sub PageOutput(func As Boolean, Optional data1 As String = "", Optional data2 = "")
'func　True 無条件出力
'　　　False 配列がいっぱいなら出力した上でセット
　　Static pV() As String
　　Static px As Long
　　Dim z As Long
　　
　　If func Then
　　　　GoSub V2Page
　　Else
　　　　If px = pgbodies Then
　　　　　　GoSub V2Page
　　　　　　px = 0
　　　　End If
　　　　
　　　　If px = 0 Then
　　　　　　ReDim pV(1 To pgbodies, 1 To 2)
　　　　End If
　　　　
　　　　px = px + 1
　　　　
　　　　pV(px, 1) = data1
　　　　pV(px, 2) = data2
　　　　
　　End If
　　
　　Exit Sub
　　
V2Page:
　　PageCnt = PageCnt + 1
　　z = (PageCnt - 1) * pgLines + 1
　　headR.Copy toSh.Cells(z, "A")
　　toSh.Cells(z + headR.Rows.Count, "A").Resize(UBound(pV, 1), UBound(pV, 2)).Value = pV
　　px = 0
Return

End Sub


	【73095】Re:データをフォーマットに記述する

ごんべえ - 12/11/9(金) 13:15 -


	引用なし

	パスワード

いつも思うこと。

●質問者のレベル
　・最初の質問では２回といいましたが、やはり３回にするにはどうすれば良いですか？というレベルの質問する人が多い。
　・コードの中の数字２を３に変えるだけで済むのに。
（質問者が悪いといっているのではなく、こういうレベルの人が多いというだけ）

●回答者
　・質問者のレベルは上記なのに、
　・ﾏｸﾛの記録をしてみて下さい。などど言う。
　・記録は出来ても、ちゃんとしたものに修正するのは、絶対に無理でしょう。
　・なんやかんや言いながら、結局はコードの全てを回答してします。
　・じゃあ　最初からそうすればと思ってしまう。
　・回答者のコードはﾏｸﾛの記録を修正したものとは、程遠いものだったりする。
　・selectを使った回答をすると非難する人も多い。
　・もともと質問者のレベルがその程度なので、selectを使ったほうが、よっぽどコードが読みやすいと思う。

●
　・そもそも困っている人を助けようという精神なら、どんな内容でもいいんじゃないですか。
　・質問者もどうどうと丸投げでの質問ですが、よろしくお願いしますでいいんじゃないですか。
　・回答のコードも動けばいいんじゃないですか。
　・そのコードが理解できて、改善したいという意欲がある質問者なら、また、改めて、別の質問なりで聞いてくるでしょう。

面倒なので硬い口調になってしまいましたが、やわらかい口調に変えてお読みください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1616 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free