Excel VBA質問箱 IV

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

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


22987 / 76732 ←次へ | 前へ→

【59116】Re:マクロでのオートSUM
発言  Hirofumi  - 08/11/29(土) 11:46 -

引用なし
パスワード
   もう少し処理速度を上げるにはこんなかな?

Option Explicit

Public Sub Sample2()

  '◆データ列数(A列のみ)
  Const clngColumns As Long = 1
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim lngNumb() As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim lngCalculation As Long
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする
  Set rngList = ActiveSheet.Cells(1, "A")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '列データを配列に取得
    vntData = .Resize(lngRows + 1).Value
    '整列Keyを保存する配列を確保
    ReDim lngNumb(1 To lngRows + 1, 1 To 1)
  End With
  
  With Application
    '画面更新を停止
    .ScreenUpdating = False
    '再計算モードを保存
    lngCalculation = .Calculation
    '再計算モードを手動に設定
    .Calculation = xlCalculationManual
  End With
  
  With rngList
    '同一値の行数を初期値に
    lngCount = 1
    For i = 2 To lngRows + 1
      If vntData(i, 1) <> vntData(i - 1, 1) Then
        '整列Key値を更新
        lngNumb(i, 1) = lngNumb(i - 1, 1) + 1
        '最終行の下に数式を出力
        .Offset(lngRows).FormulaR1C1 = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
        '整列Keyを出力
        .Offset(lngRows, clngColumns).Value = lngNumb(i, 1) - 1
        lngRows = lngRows + 1
        '先頭行位置を保存
        lngTop = i - 1
        '同一値の行数を初期値に
        lngCount = 1
      Else
        '同一値の行数を更新
        lngCount = lngCount + 1
        '整列Key値を代入
        lngNumb(i, 1) = lngNumb(i - 1, 1)
      End If
    Next i
    '整列Keyを出力
    .Offset(, clngColumns).Resize(UBound(lngNumb, 1) - 1).Value = lngNumb
    '整列Keyで行整列
    DataSort .Resize(lngRows, clngColumns + 1), .Offset(, clngColumns)
    '整列Keyを削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
  
  strProm = "処理が完了しました"
   
Wayout:
  
  With Application
    '再計算モードを元に戻す
    .Calculation = lngCalculation
    '再計算実行
    .Calculate
    '画面更新を再開
    .ScreenUpdating = True
  End With
  
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

0 hits

【59109】マクロでのオートSUM tantan 08/11/29(土) 0:04 質問
【59110】Re:マクロでのオートSUM Yuki 08/11/29(土) 8:13 発言
【59111】Re:マクロでのオートSUM Hirofumi 08/11/29(土) 8:14 発言
【59116】Re:マクロでのオートSUM Hirofumi 08/11/29(土) 11:46 発言
【59130】Re:マクロでのオートSUM tantan 08/11/29(土) 23:06 質問
【59131】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 0:18 回答
【59132】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 0:43 回答
【59133】Re:マクロでのオートSUM tantan 08/11/30(日) 0:47 質問
【59134】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 1:45 回答
【59151】Re:マクロでのオートSUM tantan 08/11/30(日) 18:54 質問
【59157】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 20:48 回答
【59166】Re:マクロでのオートSUM tantan 08/12/1(月) 0:28 質問
【59168】Re:マクロでのオートSUM SS 08/12/1(月) 9:47 発言
【59195】Re:マクロでのオートSUM tantan 08/12/2(火) 0:57 質問
【59196】Re:マクロでのオートSUM ichinose 08/12/2(火) 8:09 発言
【59263】Re:マクロでのオートSUM tantan 08/12/4(木) 0:41 お礼
【59266】Re:マクロでのオートSUM ichinose 08/12/4(木) 6:22 発言
【59197】Re:マクロでのオートSUM Jaka 08/12/2(火) 9:33 発言
【59224】Re:マクロでのオートSUM Hirofumi 08/12/2(火) 18:43 回答
【59225】Re:マクロでのオートSUM Hirofumi 08/12/2(火) 19:24 回答
【59262】Re:マクロでのオートSUM tantan 08/12/4(木) 0:36 お礼
【59283】Re:マクロでのオートSUM Hirofumi 08/12/4(木) 19:29 回答
【59310】Re:マクロでのオートSUM tantan 08/12/5(金) 18:06 お礼
【59228】Re:マクロでのオートSUM n 08/12/2(火) 21:24 発言
【59264】Re:マクロでのオートSUM tantan 08/12/4(木) 1:50 質問
【59265】Re:マクロでのオートSUM n 08/12/4(木) 3:06 発言
【59311】Re:マクロでのオートSUM tantan 08/12/5(金) 18:08 お礼

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