Excel VBA質問箱 IV

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

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


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

9209 / 76738

←次へ　｜　前へ→


	【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

0 hits

▼

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