| |
やっている事はさして変わんないけど
この方が幾らかスマートかな？（幾分速く成るかも？）
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
|
|
Hirofumi
- 08/10/23(木) 22:38 -
