Excel VBA質問箱 IV

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

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


9203 / 76732 ←次へ | 前へ→

【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

1 hits

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

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