Excel VBA質問箱 IV

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

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


2369 / 13646 ツリー ←次へ | 前へ→

【68445】効率化UPお願いします。 ののか 11/3/8(火) 17:16 質問[未読]
【68447】Re:効率化UPお願いします。 kanabun 11/3/8(火) 17:26 発言[未読]
【68448】Re:効率化UPお願いします。 ののか 11/3/8(火) 17:31 質問[未読]
【68449】Re:効率化UPお願いします。 kanabun 11/3/8(火) 17:36 発言[未読]
【68451】Re:効率化UPお願いします。 kanabun 11/3/8(火) 18:40 発言[未読]
【68452】Re:効率化UPお願いします。 kanabun 11/3/8(火) 19:54 質問[未読]
【68454】Re:効率化UPお願いします。 ののか 11/3/9(水) 8:58 発言[未読]
【68455】Re:効率化UPお願いします。 kanabun 11/3/9(水) 9:44 発言[未読]
【68456】Re:効率化UPお願いします。 ののか 11/3/9(水) 9:55 お礼[未読]
【68453】Re:効率化UPお願いします。 kanabun 11/3/8(火) 20:04 質問[未読]
【68457】Re:効率化UPお願いします。 ののか 11/3/9(水) 10:21 質問[未読]
【68458】Re:効率化UPお願いします。 kanabun 11/3/9(水) 10:46 発言[未読]
【68459】Re:効率化UPお願いします。 ののか 11/3/9(水) 10:55 お礼[未読]

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

引用なし
パスワード
   いつもお世話になってます。
自分なりに書いてみましたが、
処理に30分くらいかかってしまいます。
すみませんが宜しくお願いします。


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

【68447】Re:効率化UPお願いします。
発言  kanabun  - 11/3/8(火) 17:26 -

引用なし
パスワード
   ▼ののか さん:

>処理に30分くらいかかってしまいます。

よくみてませんが、
セルを参照するのでなく、配列内で処理すると
格段に速くなりますよ。

【68448】Re:効率化UPお願いします。
質問  ののか  - 11/3/8(火) 17:31 -

引用なし
パスワード
   #kanabunさん
いつもすいません。
まだまだ素人で、配列で処理がわかりません。
急ぎませんので、修正頂けませんか?
お忙しいところ、申しわけありませんが宜しくお願いします。

【68449】Re:効率化UPお願いします。
発言  kanabun  - 11/3/8(火) 17:36 -

引用なし
パスワード
   ▼ののか さん:

>まだまだ素人で、配列で処理がわかりません。
>急ぎませんので、修正頂けませんか?

時間があるときでよいのなら考えてみますが、
そのまえに ののか さんのほうで、
処理内容の概要を日本語で説明してもらえませんでしょうか?
シートレイアウトとか、
一行づつ内容を理解するのが億劫なので m(_ _)m

【68451】Re:効率化UPお願いします。
発言  kanabun  - 11/3/8(火) 18:40 -

引用なし
パスワード
   それとですね...

そのコード、宣言されていない変数が使われています。
> HINBANB, HINBANA

モジュールの先頭に
Option Explicit
を宣言して、[デバッグ]-[プロジェクトのコンパイル]をしてみてください。

【68452】Re:効率化UPお願いします。
質問  kanabun  - 11/3/8(火) 19:54 -

引用なし
パスワード
   なんどもすみません。
シートについて少し教えてください。

マッチングする2つのシートは、
変数MAIN ("Sheet1") と
変数REF ("2006") ということだとおもいますが、

Q1. 両シートの大体のデータ行数はいかほどですか?
Q2. 両シートの大体のデータ列数はいかほどですか?

Q3. MAINシートのA列(GENKYOKU?)データに重複はありますか?
Q4. MAINシートのD列(MAIN品番?)に重複はありますか?

Q5. REF シートのA列(GENKYOKU2?)データに重複はありますか?
Q6. REF シートのF列(REF品番?)に重複はありますか?

以上について、おしえてください

【68453】Re:効率化UPお願いします。
質問  kanabun  - 11/3/8(火) 20:04 -

引用なし
パスワード
   ▼ののか さん:
またまた、すみません
大事なことをお聞きするのを忘れてました。

> StrComp(HINBANM, HINBANR, vbTextCompare)
> StrComp(GENKYOKU, GENKYOKU2, vbTextCompare)

文字列の比較に StrComp(  ,vbTextCompare)
を用いてらっしゃいますが、これは絶対に必要ですか?
データは英数半角ですか?
それとも 全角あり なのでしょうか?

【68454】Re:効率化UPお願いします。
発言  ののか  - 11/3/9(水) 8:58 -

引用なし
パスワード
   ▼kanabun さん:
返信遅くなって申しわけありません。
下記回答入れました。
REFの 2006は書き換えして使ってます。2004〜2010までシートがあります。
MAIN H列に2004 〜 N列に2010 までです。

>マッチングする2つのシートは、
>変数MAIN ("Sheet1") と
>変数REF ("2006") ということだとおもいますが、
>
>Q1. 両シートの大体のデータ行数はいかほどですか?
>Q2. 両シートの大体のデータ列数はいかほどですか?

MAIN M列 14491行 REF T列 約5000行

>
>Q3. MAINシートのA列(GENKYOKU?)データに重複はありますか?
あります
>Q4. MAINシートのD列(MAIN品番?)に重複はありますか?
ありません  
>Q5. REF シートのA列(GENKYOKU2?)データに重複はありますか?
あります
>Q6. REF シートのF列(REF品番?)に重複はありますか?
ありません
>
全角は必要ありません。

>以上について、おしえてください

【68455】Re:効率化UPお願いします。
発言  kanabun  - 11/3/9(水) 9:44 -

引用なし
パスワード
   ▼ののか さん:

>全角は必要ありません。
了解です。

>REFの 2006は書き換えして使ってます。2004〜2010までシートがあります。
>MAIN H列に2004 〜 N列に2010 までです。

ということは、2004〜2010 により、参照シート名と更新シート(MAIN)の
データ更新列が変わる、ということですね。

こういうときは、共通処理部分をサブプロシージャに独立させ、
変化するパラメータを引数にして そのサブプロシージャを呼び出す
ようにすると、分かりやすいのではないかと思います。

'↓更新シート, 更新列番号, 参照シート を指定してサブプロシージャを
' 呼び出します。
Public Sub 品番走査数量書き込み()
  UpdateData Worksheets("Sheet1"), 10, Worksheets("2006")
End Sub

'-------------------- ↓更新するシート  更新列     参照するシート
Private Sub UpdateData(shtMAIN As Worksheet, toCol As Long, shtREF As Worksheet)
  Dim str品番M   'MAIN品番名の配列
  Dim str品番R   'REF品番名 の配列
  Dim strAMain   'MAIN側 A列の配列
  Dim strARef   'REF側 A列の配列
  Dim CopyTo, rngCopyTo As Range '更新先列のデータ配列およびその範囲
  Dim CopyFrom          '参照先列データの配列
  Dim DelInf           '行削除用パラメータ配列
  Dim dic As Object       '参照キーと行番号を格納する連想配列
  Dim ss As String
  Dim i As Long, n As Long, mm As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  '[MAIN]シート 比較列を配列に入れる
  With shtMAIN.Range("A1").CurrentRegion
    strAMain = .Columns(1).Cells.Value
    str品番M = .Columns(4).Cells.Value
    Set rngCopyTo = .Columns(toCol).Cells
    CopyTo = rngCopyTo.Value
    For i = 2 To UBound(strAMain)
      ' A列とD列の文字列をTABで結合して検索キーとする
      dic(UCase$(strAMain(i, 1) & vbTab & str品番M(i, 1))) = i
    Next
  End With
  
  '[REF]シート 比較列を配列に入れる
  With shtREF.Range("A1").CurrentRegion
    strARef = .Columns(1).Cells
    str品番R = .Columns(6).Cells
    CopyFrom = .Columns(15).Cells.Value
    mm = .Columns.Count
    ReDim DelInf(1 To .Rows.Count, 0)   '行削除用フラグ
  End With
    
  'マッチング
  DelInf(1, 0) = 1
  For i = 2 To UBound(strARef)
    '[REF]シート A列とF列文字列をTABで結合して
    ss = UCase$(strARef(i, 1) & vbTab & str品番R(i, 1))
    'このキーが dicに存在するか調べる
    If dic.Exists(ss) Then        '存在すれば、
      n = dic(ss)            '[REF]のこの行の値を
      CopyTo(n, 1) = CopyFrom(i, 1)   '[Main]の該当行に転送
                  'Deleteフラグは無番号のまま(あとで行削除)
    Else          '存在しないばあい
      DelInf(i, 0) = i  'DeleteInfには行番号を代入(あとで削除しない)
    End If
  Next
  '更新値をシートに書き出す
  rngCopyTo.Value = CopyTo
  
  '[REF]シートの転記が終わった行を削除
  With shtREF.Range("A1").CurrentRegion.Resize(, mm + 1)
    .Columns(mm + 1).Value = DelInf
    .Sort Key1:=.Columns(mm + 1), Header:=xlYes
    .Columns(mm + 1).Cells.SpecialCells(xlBlanks).EntireRow.Delete
    .Columns(mm + 1).Clear
  End With
  Set dic = Nothing
  
  Application.Goto rngCopyTo
  MsgBox "更新完了", vbInformation
End Sub

【68456】Re:効率化UPお願いします。
お礼  ののか  - 11/3/9(水) 9:55 -

引用なし
パスワード
   ありがとうございました。
迅速な対応ありがとうござました。
次回からはコードを貼り付けるのではなく、
日本語での説明も入れるようにします。

まだ、頂いたコードを見ていませんが、じっくり理解したいと思います。
いつもいつも、勉強になります。
ありがとうございました。

また、この件で質問するかもしれませんが宜しくお願いします。
詳しく書いていただいてますので大丈夫かと思いますが・・・
とにかくありがとうございました(^^♪

【68457】Re:効率化UPお願いします。
質問  ののか  - 11/3/9(水) 10:21 -

引用なし
パスワード
   ▼kanabun さん:
つかぬことをお伺いしますが、
勉強の為、VBAを書く際に参考になるサイトとかはご存知ですか?
ご存知でしたら、ご教授おねがいします。

【68458】Re:効率化UPお願いします。
発言  kanabun  - 11/3/9(水) 10:46 -

引用なし
パスワード
   ▼ののか さん:

>つかぬことをお伺いしますが、
>勉強の為、VBAを書く際に参考になるサイトとかはご存知ですか?

ht tp://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/index.html
とか、
ht tp://www.officetanaka.net/excel/vba/tips/index.htm

あたりはどうですか?

【68459】Re:効率化UPお願いします。
お礼  ののか  - 11/3/9(水) 10:55 -

引用なし
パスワード
   ▼kanabun さん:

2つ目は存じてませんでした。
くわしい説明付きでわかりやすいサイトですね(^^♪
ありがとうございました。

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