Excel VBA質問箱 IV

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

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


2385 / 13645 ツリー ←次へ | 前へ→

【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 -

引用なし
パスワード
   いつもお世話になってます。
下記プログラムを書きましたが、処理に時間がかかってしまいます。
データは15,000行程ですがファイルによってバラバラです。
効率のいい方法をご教授ください。
データはP列で昇順に並んでいます。


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 -

引用なし
パスワード
   しみったれて、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

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

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

2385 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free