Excel VBA質問箱 IV

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

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


23687 / 76732 ←次へ | 前へ→

【58407】Re:Arrayの使い方について
発言  Hirofumi  - 08/10/23(木) 22:38 -

引用なし
パスワード
   やっている事はさして変わんないけど
この方が幾らかスマートかな?(幾分速く成るかも?)

Option Explicit

Public Sub Sample2()

  '◆データ列数(A列〜Q列)
  Const clngColumns As Long = 17
  '◆勘定科目の列を指定(基準列からの列Offsetで指定:E列=4)
  Const clngItems As Long = 4
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim vntItems As Variant
  Dim vntItem As Variant
  Dim lngCount As Long
  Dim blnOthers As Boolean
  Dim strProm As String

  '◆Sheet1の先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(6, "A")
  
  '◆Sheet2の先頭セル位置を基準とする
  Set rngResult = Worksheets("Sheet2").Cells(2, "A")

  '画面更新を停止
  Application.ScreenUpdating = False
  
  vntItems = Array("", "入金票", "交換小切手", "先付小切手", _
          "福利厚生積立金", "退職積立金", "受取手形", _
          "売掛金", "未収金", "支払手形", "買掛金", _
          "未払金", "給料", "賞与", "退職金", _
          "法定福利費", "福利厚生費", "旅費交通費", _
          "通信費", "運賃", "広告宣伝費", "・・・・・など91の勘定科目があります")
          
  With rngResult
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows > 0 Then
      '結果を消去
      .Offset(1).Resize(lngRows, clngColumns).ClearContents
    End If
  End With
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'Sheet1をSheet2にCopy
    .Offset(1).Resize(lngRows + 1, clngColumns).Copy Destination:=rngResult
  End With
  
  With rngResult
    '勘定科目の列をKeyとして整列
    .Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset(, clngItems), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '勘定科目の列を配列に取得
    vntData = .Offset(, clngItems).Resize(lngRows + 1).Value
  End With
  
  '整列Keyを作成
  lngCount = lngRows - 1
  For i = 1 To lngRows + 1
    '勘定科目が違ったら
    If vntItem <> vntData(i, 1) Then
      vntItem = vntData(i, 1)
      '勘定科目配列に値が有るかを確認
      For j = 1 To UBound(vntItems)
        If vntItems(j) = vntData(i, 1) Then
          Exit For
        End If
      Next j
      If j <= UBound(vntItems) Or blnOthers = False Then
        '最終行の下に列見出しと番号を出力
        lngCount = lngCount + 1
        rngResult.Offset(lngCount, clngColumns).Resize(2).Value = j - 0.5
        lngCount = lngCount + 1
        rngList.Resize(, clngColumns).Copy _
            Destination:=rngResult.Offset(lngCount)
      End If
      If j > UBound(vntItems) Then
        blnOthers = True
      End If
    End If
    '整列Keyを配列に出力
    vntData(i, 1) = j
  Next i

  With rngResult
    '整列KeyをSheet2に出力
    .Offset(, clngColumns).Resize(lngRows).Value = vntData
    '整列Keyでデータを整列
    .Resize(lngCount + 1, clngColumns + 1).Sort _
        Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '整列Keyを消去
    .Offset(1, clngColumns).EntireColumn.ClearContents
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub
0 hits

【58372】Arrayの使い方について taichi 08/10/21(火) 21:37 質問
【58374】Re:Arrayの使い方について neptune 08/10/21(火) 22:15 発言
【58384】Re:Arrayの使い方について taichi 08/10/22(水) 21:32 質問
【58386】Re:Arrayの使い方について Hirofumi 08/10/22(水) 21:58 発言
【58407】Re:Arrayの使い方について Hirofumi 08/10/23(木) 22:38 発言
【58399】Re:Arrayの使い方について kanabun 08/10/23(木) 14:27 発言
【58458】Re:Arrayの使い方について taichi 08/10/27(月) 7:15 質問
【58459】Re:Arrayの使い方について kanabun 08/10/27(月) 10:09 発言
【58558】Re:Arrayの使い方について taichi 08/10/29(水) 22:27 お礼

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