Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2386 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【68352】セルを比べて同じなら・・・ ののか 11/2/25(金) 15:54 質問[未読]
【68353】Re:セルを比べて同じなら・・・ Jaka 11/2/25(金) 16:36 発言[未読]
【68354】Re:セルを比べて同じなら・・・ ののか 11/2/25(金) 16:50 お礼[未読]
【68356】Re:セルを比べて同じなら・・・ Jaka 11/2/25(金) 17:16 発言[未読]
【68358】Re:セルを比べて同じなら・・・ ののか 11/2/25(金) 17:24 お礼[未読]
【68359】Re:セルを比べて同じなら・・・ SK63 11/2/25(金) 17:52 発言[未読]
【68355】Re:セルを比べて同じなら・・・ kanabun 11/2/25(金) 17:06 発言[未読]
【68357】Re:セルを比べて同じなら・・・ ののか 11/2/25(金) 17:23 お礼[未読]
【68352】セルを比べて同じなら・・・
質問  ののか  - 11/2/25(金) 15:54 -
引用なし
パスワード
   いつもお世話になってます。
下記プログラムを書きましたが、処理に時間がかかってしまいます。
データは１５，０００行程ですがファイルによってバラバラです。
効率のいい方法をご教授ください。
データはＰ列で昇順に並んでいます。


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
【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
【68354】Re:セルを比べて同じなら・・・
お礼  ののか  - 11/2/25(金) 16:50 -
引用なし
パスワード
   有難うございました。
ですが、あまりスピードが上がりません・・・。
【68355】Re:セルを比べて同じなら・・・
発言  kanabun  - 11/2/25(金) 17:06 -
引用なし
パスワード
   ▼ののか さん：
おじゃまします。

すべて配列にコピーして 配列内で統合してみたらどうですか？

6列目をキーにしています。

Sub 統合プログラム()

　Dim BOOKNAME　　　　　'元ファイル名
　Dim WS1 As Worksheet　'対象シート
　Dim Target As Range　　 '処理対象範囲
　Dim i As Long, j As Long, n As Long, m As Long
　Dim v As Variant
　Dim key
　
　'ファイルを開く
　　BOOKNAME = Application.GetOpenFilename(MultiSelect:=False)
　　If VarType(BOOKNAME) = vbBoolean Then Exit Sub
　　
　　With Workbooks.Open(Filename:=BOOKNAME)
　　　　BOOKNAME = .Name
　　　　Set WS1 = .Worksheets(Left$(BOOKNAME, Len(BOOKNAME) - 4)) '対象シート
　　End With
　　Set Target = WS1.Range("A1").CurrentRegion
　　v = Target.Value
　　m = UBound(v, 2)
　　n = 1
　　For i = 2 To UBound(v)
　　　If key <> v(i, 6) Then
　　　　　key = v(i, 6)
　　　　　n = n + 1
　　　　　If n <> i Then
　　　　　　　For j = 1 To m
　　　　　　　　　v(n, j) = v(i, j)
　　　　　　　Next
　　　　　End If
　　　Else
　　　　　For j = 15 To 20
　　　　　　　v(n, j) = v(n, j) + v(i, j)
　　　　　Next
　　　End If
　　Next
　　Target.ClearContents
　　Target.Resize(n).Value = v
End Sub
【68356】Re:セルを比べて同じなら・・・
発言  Jaka  - 11/2/25(金) 17:16 -
引用なし
パスワード
   ▼ののか さん：
>ですが、あまりスピードが上がりません・・・。
あ、やっぱり。

ただ、
>Do While Len(Cells(A, 6)) > 0　　'セルの文字数0ならば
ってことは、
>Worksheets(MAIN).Cells(B, 15).Value
15列に書き込んではいけないセルもあるということですよね。
どうなんでしょうか？
【68357】Re:セルを比べて同じなら・・・
お礼  ののか  - 11/2/25(金) 17:23 -
引用なし
パスワード
   すごい！！！
一瞬で終わりました。
念のためデータ見直してみましたが完璧です。
有難うございました。
【68358】Re:セルを比べて同じなら・・・
お礼  ののか  - 11/2/25(金) 17:24 -
引用なし
パスワード
   解決しました。
ありがとうございました。
【68359】Re:セルを比べて同じなら・・・
発言  SK63  - 11/2/25(金) 17:52 -
引用なし
パスワード
   少し手直しですが、、御免なさいJAKAさん
ちゃんとﾁｪｯｸ（コード）してないのですが

画面更新を停止とループの中のSELECTを辞めてあります。
また、ループの中のWorksheets(MAIN)は入らない気がしますが

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

Public WBK1 As Workbook
Public SH1 As Worksheet


Application.ScreenUpdating = False
Application.EnableEvents = False


>　'ファイルを開く
>　　BOOKNAME = Application.GetOpenFilename(MultiSelect:=False)
>　　Workbooks.Open Filename:=BOOKNAME
 *　　Set WBK1 = ActiveWorkbook　　' 現在ブック
　 '　BOOKを開くとひらいたBOOKがアクティブに成ります
>
>
>　'シート名確保
>　　MAIN = Left(BOOKNAME, 12)
’　こういう方法もあります　　セルを指定はSH1.Cells(1, 1)で可能です
　*　　MAIN＝ActiveSheet.Name
　*　　Set SH1 = WBK1.ActiveSheet

>　 'アクティブシート名取得
>　　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　　？？このSELECTっているのかな？
’　　　　　　　　　　　　　　　ループにいる間同じｼｰﾄ指定ですね。
>　　　FLAG = StrComp(Cells(A, 6), Cells(B, 6), vbTextCompare)
>　
>　　　If FLAG = 0 Then '一致していれば

’’ここも配列にしたほうが速いです。
''
変数の宣言は外でしてください
dim ZA as variant,ZB as variant
dim i as integer

ZA = SH1.Cells(A, 15).Resize(6,1).Value
BZ = SH1.Cells(B, 15).Resize(6,1).Value
for i=15 to 20
TB(i-14)=Cells(B, i) + Cells(A, i)
next i

Cells(B, 15).Resize(, 6).Value = TB
’ここにもSELECTがありましたSELECTすると遅くなります。
Range(Cells(A, 2), Cells(A, 4)).EntireRow.Delete
A = A - 1

Else
　　　
End If
Loop
>Erase TB　'静的配列の中身消去。
>
Application.ScreenUpdating = False
Application.EnableEvents = False


End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2386 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free