Excel VBA質問箱 IV

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

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


23713 / 76738 ←次へ | 前へ→

【58386】Re:Arrayの使い方について
発言  Hirofumi  - 08/10/22(水) 21:58 -

引用なし
パスワード
   長く成るけどこんな事?

詳しく見てないので合っているのか解りませんが?
コード的には、Sheet1のデータを「勘定科目」と言う配列変数の順番に、
Sheet2にCopyして居るだけなのかな?
だとすれば、Sheet1のデータを丸ごとSheet2にCopyして
最終列の後ろを作業列とし、其処に「勘定科目の順番に番号を入れて整列(ソート)すれば善いかも?

Option Explicit

Public Sub Sample()

  '◆データ列数(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 lngCount As Long
  Dim strProm As String

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

  '画面更新を停止
  Application.ScreenUpdating = False
  
  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
    '勘定科目の列の値を配列に取得
    vntData = .Offset(1, clngItems).Resize(lngRows + 1).Value
    'Sheet1をSheet2にCopy
    .Offset(1).Resize(lngRows + 1, clngColumns).Copy Destination:=rngResult
  End With
  
  vntItems = Array("", "入金票", "交換小切手", "先付小切手", _
          "福利厚生積立金", "退職積立金", "受取手形", _
          "売掛金", "未収金", "支払手形", "買掛金", _
          "未払金", "給料", "賞与", "退職金", _
          "法定福利費", "福利厚生費", "旅費交通費", _
          "通信費", "運賃", "広告宣伝費", "・・・・・など91の勘定科目があります")
  
  '整列Keyを作成
  For i = 1 To lngRows
    '勘定科目配列に値が有るかを確認
    For j = 1 To UBound(vntItems)
      If vntItems(j) = vntData(i, 1) Then
        Exit For
      End If
    Next j
    '整列Keyを配列に出力
    vntData(i, 1) = j
  Next i

  With rngResult
    '整列KeyをSheet2に出力
    .Offset(, clngColumns).Resize(lngRows).Value = vntData
    '整列Keyでデータを整列
    .Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '整列Keyを配列に再取得
    vntData = .Offset(, clngColumns).Resize(lngRows + 1).Value
    '整列Keyを上から見て行く
    lngCount = lngRows - 1
    For i = 1 To lngRows
      '整列Keyの番号が下の行と変わったら
      If vntData(i, 1) <> vntData(i + 1, 1) Then
        '最終行の下に列見出しと番号を出力
        lngCount = lngCount + 1
        .Offset(lngCount, clngColumns).Resize(2).Value = vntData(i, 1) - 0.5
        lngCount = lngCount + 1
        rngList.Resize(, clngColumns).Copy Destination:=.Offset(lngCount)
      End If
    Next i
    '整列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
1 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 お礼

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