Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

13795 / 76738

←次へ　｜　前へ→


	【68445】効率化UPお願いします。

ののか - 11/3/8(火) 17:16 -


	引用なし

	パスワード

いつもお世話になってます。
自分なりに書いてみましたが、
処理に３０分くらいかかってしまいます。
すみませんが宜しくお願いします。

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

0 hits

▼

【68445】効率化UPお願いします。 ののか 11/3/8(火) 17:16

≪