|
いつもお世話になってます。
自分なりに書いてみましたが、
処理に30分くらいかかってしまいます。
すみませんが宜しくお願いします。
Sub 品番走査数量書き込みプログラム()
Dim MAIN As String 'Sheet1
Dim REF As String '参照用
Dim KITEN As Range
Dim C As Integer '表MAIN最終行
Dim HINBANM As String 'MAIN品番名
Dim HINBANR As String 'REF品番名
Dim A As Integer 'MAIN最終行
Dim B As Integer 'REF最終行
Dim M As Integer
Dim R As Integer
Dim FLAG As String
Dim FLAG2 As String
Dim GENKYOKU As String
Dim GENKYOKU2 As String
MAIN = "Sheet1"
REF = "2006"
'前ファイル最終行取得
Set KITEN = Worksheets(MAIN).Range("A1")
A = KITEN.CurrentRegion.Rows.Count
'後ファイル最終行取得
Set KITEN = Worksheets(REF).Range("A1")
B = KITEN.CurrentRegion.Rows.Count
For M = 2 To A 'MAIM品番
HINBANM = Worksheets(MAIN).Cells(M, 4)
GENKYOKU = Worksheets(MAIN).Cells(M, 1)
R = 2 'REF品番
Do While Len(Cells(R, 1)) > 0 'セルの文字数0ならば
HINBANR = Worksheets(REF).Cells(R, 6)
GENKYOKU2 = Worksheets(REF).Cells(R, 1)
FLAG = StrComp(HINBANB, HINBANA, vbTextCompare)
FLAG2 = StrComp(GENKYOKU, GENKYOKU2, vbTextCompare)
If FLAG = 0 Then '一致していれば
If FLAG2 = 0 Then
Worksheets(MAIN).Cells(M, 10) = Worksheets(REF).Cells(R, 15)
Worksheets(REF).Select '該当行のカット
Range(Cells(R, 2), Cells(R, 4)).EntireRow.Delete
R = R + 1
Else
R = R + 1
End If
End If
Loop
Next M
End Sub
|
|