Excel VBA質問箱 IV

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

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


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

13956 / 76807

←次へ　｜　前へ→


	【68353】Re:セルを比べて同じなら・・・

Jaka - 11/2/25(金) 16:36 -


	引用なし

	パスワード

しみったれて、１行分の配列しか使ってないけど、
多少は早くなると思います。

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 '←ちゃんと２次元にしようかと思ったけれど１次元

　'ファイルを開く
　　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

0 hits

▼

【68352】セルを比べて同じなら・・・ ののか 11/2/25(金) 15:54