| |
いつもお世話になってます。
下記プログラムを書きましたが、処理に時間がかかってしまいます。
データは１５，０００行程ですがファイルによってバラバラです。
効率のいい方法をご教授ください。
データはＰ列で昇順に並んでいます。
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
'ファイルを開く
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
Sheets(MAIN).Select '該当行のカット
Range(Cells(A, 2), Cells(A, 4)).EntireRow.Delete
A = A - 1
Else
End If
Loop
End Sub
|
|
ののか
- 11/2/25(金) 15:54 -
