|
しみったれて、1行分の配列しか使ってないけど、
多少は早くなると思います。
Sub 品番抽出プログラム()
Dim BOOKNAME As String '元ファイル名
Dim DISTINATION As String '変更ファイル名
Dim MAIN As String 'アクティブシート名
Dim KITEN As Range '原点
Dim C As Integer '表MAIN最終行
Dim HINBAN As String '品番名
Dim A As Integer 'カウンタ
Dim B As Integer 'サブカウンタ
Dim FLAG As String
Dim TB(1 To 6) As Variant '←ちゃんと2次元にしようかと思ったけれど1次元
'ファイルを開く
BOOKNAME = Application.GetOpenFilename(MultiSelect:=False)
Workbooks.Open Filename:=BOOKNAME
BOOKNAME = Right(BOOKNAME, 16)
Workbooks(BOOKNAME).Activate
'シート名確保
MAIN = Left(BOOKNAME, 12)
'アクティブシート名取得
Workbooks(BOOKNAME).Activate
Set KITEN = Worksheets(MAIN).Range("A1")
C = KITEN.CurrentRegion.Rows.Count '最終行取得
A = 2
Do While Len(Cells(A, 6)) > 0 'セルの文字数0ならば
A = A + 1
B = A - 1
Sheets(MAIN).Select
FLAG = StrComp(Cells(A, 6), Cells(B, 6), vbTextCompare)
If FLAG = 0 Then '一致していれば
'Worksheets(MAIN).Cells(B, 14).Value = Worksheets(MAIN).Cells(B, 14).Value + Worksheets(MAIN).Cells(A, 14).Value
' Worksheets(MAIN).Cells(B, 15).Value = Worksheets(MAIN).Cells(B, 15).Value + Worksheets(MAIN).Cells(A, 15).Value
' Worksheets(MAIN).Cells(B, 16).Value = Worksheets(MAIN).Cells(B, 16).Value + Worksheets(MAIN).Cells(A, 16).Value
' Worksheets(MAIN).Cells(B, 17).Value = Worksheets(MAIN).Cells(B, 17).Value + Worksheets(MAIN).Cells(A, 17).Value
' Worksheets(MAIN).Cells(B, 18).Value = Worksheets(MAIN).Cells(B, 18).Value + Worksheets(MAIN).Cells(A, 18).Value
' Worksheets(MAIN).Cells(B, 19).Value = Worksheets(MAIN).Cells(B, 19).Value + Worksheets(MAIN).Cells(A, 19).Value
' Worksheets(MAIN).Cells(B, 20).Value = Worksheets(MAIN).Cells(B, 20).Value + Worksheets(MAIN).Cells(A, 20).Value
TB(1) = Worksheets(MAIN).Cells(B, 15).Value + Worksheets(MAIN).Cells(A, 15).Value
TB(2) = Worksheets(MAIN).Cells(B, 16).Value + Worksheets(MAIN).Cells(A, 16).Value
TB(3) = Worksheets(MAIN).Cells(B, 17).Value + Worksheets(MAIN).Cells(A, 17).Value
TB(4) = Worksheets(MAIN).Cells(B, 18).Value + Worksheets(MAIN).Cells(A, 18).Value
TB(5) = Worksheets(MAIN).Cells(B, 19).Value + Worksheets(MAIN).Cells(A, 19).Value
TB(6) = Worksheets(MAIN).Cells(B, 20).Value + Worksheets(MAIN).Cells(A, 20).Value
Worksheets(MAIN).Cells(B, 15).Resize(, 6).Value = TB
Sheets(MAIN).Select '該当行のカット
Range(Cells(A, 2), Cells(A, 4)).EntireRow.Delete
A = A - 1
Else
End If
Loop
Erase TB '静的配列の中身消去。
End Sub
|
|