| |
▼ののか さん：
>全角は必要ありません。
了解です。
>REFの 2006は書き換えして使ってます。2004〜2010までｼｰﾄがあります。
>MAIN H列に2004 〜 N列に2010 までです。
ということは、2004〜2010 により、参照シート名と更新シート(MAIN)の
データ更新列が変わる、ということですね。
こういうときは、共通処理部分をサブプロシージャに独立させ、
変化するパラメータを引数にして そのサブプロシージャを呼び出す
ようにすると、分かりやすいのではないかと思います。
'↓更新シート, 更新列番号, 参照シート を指定してサブプロシージャを
' 呼び出します。
Public Sub 品番走査数量書き込み()
UpdateData Worksheets("Sheet1"), 10, Worksheets("2006")
End Sub
'-------------------- ↓更新するシート 更新列 参照するシート
Private Sub UpdateData(shtMAIN As Worksheet, toCol As Long, shtREF As Worksheet)
Dim str品番M 'MAIN品番名の配列
Dim str品番R 'REF品番名 の配列
Dim strAMain 'MAIN側 A列の配列
Dim strARef 'REF側 A列の配列
Dim CopyTo, rngCopyTo As Range '更新先列のデータ配列およびその範囲
Dim CopyFrom '参照先列データの配列
Dim DelInf '行削除用パラメータ配列
Dim dic As Object '参照キーと行番号を格納する連想配列
Dim ss As String
Dim i As Long, n As Long, mm As Long
Set dic = CreateObject("Scripting.Dictionary")
'[MAIN]シート 比較列を配列に入れる
With shtMAIN.Range("A1").CurrentRegion
strAMain = .Columns(1).Cells.Value
str品番M = .Columns(4).Cells.Value
Set rngCopyTo = .Columns(toCol).Cells
CopyTo = rngCopyTo.Value
For i = 2 To UBound(strAMain)
' A列とD列の文字列をTABで結合して検索キーとする
dic(UCase$(strAMain(i, 1) & vbTab & str品番M(i, 1))) = i
Next
End With
'[REF]シート 比較列を配列に入れる
With shtREF.Range("A1").CurrentRegion
strARef = .Columns(1).Cells
str品番R = .Columns(6).Cells
CopyFrom = .Columns(15).Cells.Value
mm = .Columns.Count
ReDim DelInf(1 To .Rows.Count, 0) '行削除用フラグ
End With
'マッチング
DelInf(1, 0) = 1
For i = 2 To UBound(strARef)
'[REF]シート A列とF列文字列をTABで結合して
ss = UCase$(strARef(i, 1) & vbTab & str品番R(i, 1))
'このキーが dicに存在するか調べる
If dic.Exists(ss) Then '存在すれば、
n = dic(ss) '[REF]のこの行の値を
CopyTo(n, 1) = CopyFrom(i, 1) '[Main]の該当行に転送
'Deleteフラグは無番号のまま(あとで行削除)
Else '存在しないばあい
DelInf(i, 0) = i 'DeleteInfには行番号を代入（あとで削除しない）
End If
Next
'更新値をシートに書き出す
rngCopyTo.Value = CopyTo
'[REF]シートの転記が終わった行を削除
With shtREF.Range("A1").CurrentRegion.Resize(, mm + 1)
.Columns(mm + 1).Value = DelInf
.Sort Key1:=.Columns(mm + 1), Header:=xlYes
.Columns(mm + 1).Cells.SpecialCells(xlBlanks).EntireRow.Delete
.Columns(mm + 1).Clear
End With
Set dic = Nothing
Application.Goto rngCopyTo
MsgBox "更新完了", vbInformation
End Sub
|
|
kanabun
- 11/3/9(水) 9:44 -
