| |
長く成るけどこんな事？
詳しく見てないので合っているのか解りませんが？
コード的には、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
|
|
Hirofumi
- 08/10/22(水) 21:58 -
