Excel VBA質問箱 IV

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

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


1618 / 13646 ツリー ←次へ | 前へ→

【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 -

引用なし
パスワード
   ▼はみりん さん:

こんにちは

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

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

この作業を行うことを指示されたけれども、手作業では面倒なので
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がデータブックとしての扱いでもOKです)
・実行時にはA.xlsもB.xlsも、ともに開かれていることが前提です。
・A.xls、B.xlsの対象シート名が不明でしたので、どちらも "Sheet1" にしてあります。
・A.xls の 対象シートのA列は定時サンプル通り、【正しく連番】がふられているということを
 前提にしています。つまり、A列データの最終行のセルの値が【ユニークな車名の数】ということです。
・B.xls の 対象シートの先頭の3行(A1:B3")には、あらかじめ、任意の書式のタイトルが設定されている
 ということを前提にしています。
 (A,B列の4行目以降は、何かあってもなくても、コード内でクリアします)
・B.xls の 対象シートの C列以降右側には何もないということを前提にしています。

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

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")   '3行のタイトル域の保存
    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        '保存した3行タイトルをクリア
    '★ 車名行の罫線削除
    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 -

引用なし
パスワード
   いつも思うこと。

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


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


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

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

1618 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free