Excel VBA質問箱 IV

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

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


8781 / 76732 ←次へ | 前へ→

【73519】Re:コードを整理したい
発言  UO3  - 13/1/17(木) 19:53 -

引用なし
パスワード
   ▼たろう さん:

ではアップ済みのものをベースに図にしたてあげたものです。
図は、SHeet2に作成します。

Sub Sample2()

  Const stFlow As String = "D9"
  Const stCell As String = "E14"
  
  Dim lMax As Long
  Dim v() As String
  Dim joinR() As Range
  Dim c As Range
  Dim k As Long
  Dim oLvl As Long
  Dim myR As Range
  Dim i As Long
  Dim j As Long
  Dim flg As Boolean
  
  With Sheets("Sheet1")    '元シート
    With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      lMax = WorksheetFunction.Max(.Columns(1))
      ReDim v(1 To .Rows.Count, 1 To lMax)
      ReDim joinR(1 To lMax)
      For Each c In .Columns(1).Cells
        If c.Value = 1 Or c.Value <= oLvl Then k = k + 1
        v(k, c.Value) = c.Offset(, 1).Value
        oLvl = c.Value
      Next
    End With
  End With
      
  With Sheets("Sheet2")    '転記シート
    With .UsedRange
      .Borders.LineStyle = xlNone
      .ClearContents
      .MergeCells = False
    End With
    
    Set myR = .Range(stCell)
    Set joinR(1) = .Range(stFlow)
    
    For i = 1 To k
      For j = 1 To UBound(v, 2)
        If Len(v(i, j)) > 0 Then
          myR.Resize(5).Merge
          myR.Value = v(i, j)
          With myR.Resize(5)
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
          End With
          flg = False
          If j = 1 Then
            flg = True
          ElseIf Len(v(i, j - 1)) = 0 Then
            flg = True
          End If
          
          If flg Then
            With .Range(joinR(j), myR.Offset(, -1))
              .Borders(xlEdgeLeft).LineStyle = xlContinuous
              .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
          Else
            myR.Offset(, -2).Resize(, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
          End If
          Set joinR(j) = myR.Offset(, -1).Offset(1)
        End If
        Set myR = myR.Offset(, 3)
      Next
      
      Set myR = myR.Offset(6).EntireRow.Cells(.Range(stCell).Column)
      
    Next
      
    .Select
    
  End With
  
  MsgBox "転記完了です"
  
End Sub

277 hits

【73512】コードを整理したい たろう 13/1/17(木) 11:45 質問
【73513】Re:コードを整理したい UO3 13/1/17(木) 12:14 発言
【73514】Re:コードを整理したい UO3 13/1/17(木) 12:20 発言
【73516】Re:コードを整理したい たろう 13/1/17(木) 15:29 発言
【73517】Re:コードを整理したい UO3 13/1/17(木) 16:01 発言
【73518】Re:コードを整理したい たろう 13/1/17(木) 16:24 発言
【73519】Re:コードを整理したい UO3 13/1/17(木) 19:53 発言
【73520】Re:コードを整理したい UO3 13/1/17(木) 20:30 発言
【73527】Re:コードを整理したい たろう 13/1/18(金) 10:38 発言
【73528】Re:コードを整理したい UO3 13/1/18(金) 10:46 発言
【73529】Re:コードを整理したい たろう 13/1/18(金) 11:07 発言
【73530】Re:コードを整理したい UO3 13/1/18(金) 14:37 発言
【73557】Re:コードを整理したい たろう 13/1/21(月) 10:22 お礼

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