| |
もう見て居ないかな？
与えられるデータ、作成される表等に不明な点が有りますので
推測で書きますので、違っていたらゴメン
マクロはBook2に有る物とします
Book2のSheet1は、最初何も入力されていない物とします
初回（6月cost時）Book1で与えられるデータは、以下の様なレイアウトとします
Book1.Sheet1
A B C
1 P/N name 6月cost
2 1234 りんご 30
3 4567 ばなな 15
4 7890 ぶどう 90
Book2.Sheet1の初回は、転記されるだけなので
Book1.Sheet1と同じに成ります
2回目（7月cost時）は、以下の様に与えられ
Book1.Sheet1
A B C
1 P/N name 7月cost
2 1234 りんご 35
3 2345 もも 10
4 5678 メロン 20
5 7890 ぶどう 95
6 8910 なし 5
Book2.Sheet1は、以下の様に成ります
Book2.Sheet1
A B C D
1 P/N name 6月cost 7月cost
2 1234 りんご 30 35
3 2345 もも 10
4 4567 ばなな 15 15
5 5678 メロン 20
6 7890 ぶどう 90 95
7 8910 なし 5
転記していく条件は、
1、「P/N」が「6月cost」に有り「7月cost」有る場合
「7月cost」に新しい値が更新される
2、「P/N」が「6月cost」に有り「7月cost」無い場合
「7月cost」に「6月cost」の値が繰り越される
3、「P/N」が「6月cost」に無く「7月cost」有る場合
新規の行が作成され、「P/N」、「name」が書きこまれ
「7月cost」に新しい値が更新され、
「6月cost」は、ブランクに成る
以下をBook2の標準モジュールに記述して下さい
Option Explicit
Public Sub AddUp()
Const lngRowEnd As Long = 65536
Dim i As Long
Dim rngScope As Range
Dim lngRow As Long
Dim lngCol As Long
Dim lngFound As Long
Dim lngOver As Long
Dim vntData As Variant
Dim vntDataFile As Variant
Dim rngResultTop As Range
'入力ファイルを取得
If Not GetReadFile(vntDataFile, _
ThisWorkbook.Path, False) Then
Exit Sub
End If
'画面更新の停止
Application.ScreenUpdating = False
'入力ファイルをOpen
With Workbooks
'入力ファイルをOpen
.Open (vntDataFile)
End With
'データを取得
With ActiveWorkbook.Worksheets("Sheet1")
vntData = Range(.Cells(1, "A"), _
.Cells(lngRowEnd, "C").End(xlUp)).Value
End With
'入力ファイルをClose
ActiveWorkbook.Close
'出力先頭セルを設定
Set rngResultTop _
= ThisWorkbook.Worksheets("Sheet1").Cells(1, "A")
With rngResultTop
'集計列が先頭の場合、値を張り付けソートを行う
If rngResultTop.Value = "" Then
'データを代入
.Resize(UBound(vntData, 1), _
UBound(vntData, 2)).Value = vntData
'データをソート
DataSort rngResultTop
Else
'集計列の取得(最終列の次の列）
lngCol = .End(xlToRight).Column
'行数を取得
lngRow = .End(xlDown).Row - .Row
'当月の列見出しを代入
.Offset(, lngCol) = vntData(1, 3)
'前月のcostを当月に転記
.Offset(1, lngCol).Resize(lngRow).Value _
= .Offset(1, lngCol - 1).Resize(lngRow).Value
'探索範囲を取得
Set rngScope = .Offset(1).Resize(lngRow)
'データの先頭から終りまで繰り返し
For i = 2 To UBound(vntData, 1)
'P/Nを探索
lngFound = RowSearchBin(vntData(i, 1), _
rngScope, lngOver)
'P/Nが無い場合
If lngFound = -1 Then
'挿入位置を発見位置に
lngFound = lngOver
'行挿入
.Offset(lngFound, lngCol).EntireRow.Insert
'挿入した行の先頭にP/Nを記入
.Offset(lngFound, 0).Value = vntData(i, 1)
'挿入した行の先頭2列目にnameを記入
.Offset(lngFound, 1).Value = vntData(i, 2)
'行数を更新
lngRow = lngRow + 1
'探索範囲を再取得
Set rngScope = .Offset(1).Resize(lngRow)
End If
'単価、数量を記入
.Offset(lngFound, lngCol).Value = vntData(i, 3)
Next i
End If
End With
Set rngScope = Nothing
Set rngResultTop = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Function RowSearchBin(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long) As Long
Dim vntFind As Variant
RowSearchBin = -1
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, 1)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
RowSearchBin = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
Else
lngOver = 1
End If
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean _
= False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "Excel File (*.xls),*.xls," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames, False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
Private Sub DataSort(rngTop As Range)
rngTop.CurrentRegion.Sort _
Key1:=rngTop, Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
End Sub
|
|
Hirofumi
- 04/7/31(土) 14:26 -
