Excel VBA質問箱 IV

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

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


4482 / 76733 ←次へ | 前へ→

【77873】Re:規定数で区切るには
回答  ウッシ  - 16/1/16(土) 9:08 -

引用なし
パスワード
   こんにちは

差し替えで、標準モジュールの先頭から、

Option Explicit
Const 規定数 As Long = 10
Const 不足分 As Long = 2
Const 余剰分 As Long = 2

Sub test1_0()
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim wsh As Worksheet
  Dim r  As Range
  Dim s  As Range
  Dim i  As Long
  Dim j  As Long
  
  Set sh1 = Worksheets("Sheet1")
  Set sh2 = Worksheets("Sheet2")
  Set wsh = Worksheets.Add
 
  Application.ScreenUpdating = False
 
  sh2.Range("A1").CurrentRegion.Offset(1).ClearContents
 
  wsh.Range("A1:C1").Value = sh1.Range("A1:C1").Value
  wsh.Range("D1").Value = "グループ"
 
  i = 2
  For Each r In sh1.Range("A2", sh1.Range("A2").End(xlDown))
    wsh.Cells(i, 1).Resize(r(1, 3), 3).Value = r.Resize(, 3).Value
    i = i + r(1, 3)
  Next
 
  Call test1_1(wsh)
  
  wsh.Range("A1").CurrentRegion.Subtotal _
    GroupBy:=4, Function:=xlCount, TotalList:=Array(3), _
    Replace:=True, PageBreaks:=False, SummaryBelowData:=True
 
  Set s = wsh.Range("D2", wsh.Range("D2").End(xlDown).Offset(-1, 0)) _
          .Offset(, -3).SpecialCells(xlCellTypeBlanks)
  
  
  For Each r In s
    r.Offset(-1, 0).Resize(, 2).Copy _
      sh2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    sh2.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
      r.Offset(0, 2).Value
  Next

  With sh2.Range("C2", sh2.Range("C2").End(xlDown)).Offset(0, 1)
    .Formula = "=IF(D1>=" & 規定数 - 不足分 & ",C2,D1+C2)"
    .Value = .Value
  End With
 
  Application.DisplayAlerts = False
  wsh.Delete
  Application.DisplayAlerts = True
 
  Application.ScreenUpdating = True

End Sub

Sub test1_1(tSh As Worksheet)
  Dim e As Long
  Dim i As Long
  Dim j As Long
  Dim k As Long
  
  With tSh
    e = .Range("A1").CurrentRegion.Rows.Count
    k = 1
    For i = 2 To e
      .Cells(i, 4) = k & .Cells(i, 2)
      If Cells(i, 2) = .Cells(i + 1, 2) Then
        j = j + 1
        If j >= 規定数 And WorksheetFunction.CountIf( _
          .Range(.Cells(i + 1, 2), .Cells(e, 2)), Cells(i, 2)) <= 余剰分 Then
            .Cells(i, 4) = .Cells(i - 1, 4)
        Else
          If j >= 規定数 Then
            k = k + 1
            j = 0
          End If
        End If
      Else
        If j >= 規定数 Then
          .Cells(i, 4) = .Cells(i - 1, 4)
          j = 0
        End If
        If .Cells(i, 2) = .Cells(i + 1, 2) Then
          j = 0
        Else
          If j >= 規定数 - 不足分 - 1 And j < 規定数 Then
            j = 0
          Else
            If j > 0 Then
              j = j + 1
            End If
          End If
        End If
      End If
    Next
  End With
End Sub
1 hits

【77864】規定数で区切るには karasu 16/1/15(金) 6:13 質問[未読]
【77865】Re:規定数で区切るには β 16/1/15(金) 10:12 発言[未読]
【77866】Re:規定数で区切るには ウッシ 16/1/15(金) 10:42 回答[未読]
【77869】Re:規定数で区切るには karasu 16/1/16(土) 3:38 お礼[未読]
【77871】Re:規定数で区切るには γ 16/1/16(土) 8:44 発言[未読]
【77874】Re:規定数で区切るには karasu 16/1/16(土) 13:08 回答[未読]
【77879】Re:規定数で区切るには γ 16/1/16(土) 23:52 発言[未読]
【77880】Re:規定数で区切るには karasu 16/1/17(日) 2:10 お礼[未読]
【77873】Re:規定数で区切るには ウッシ 16/1/16(土) 9:08 回答[未読]
【77875】Re:規定数で区切るには karasu 16/1/16(土) 13:19 お礼[未読]

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