Excel VBA質問箱 IV

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

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


13780 / 76733 ←次へ | 前へ→

【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

2 hits

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

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