Excel VBA質問箱 IV

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

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


27269 / 76738 ←次へ | 前へ→

【54792】Re:Workbooksの引数でフルパス指定が原因?
お礼  jax_6  - 08/3/30(日) 12:12 -

引用なし
パスワード
   n様、さらなるご教授ありがとうございましたm(_ _)m

>補足ですが、ActivateやSelectに頼ると状況によっては不具合の元ですし、
>実行速度にも影響してきます。
オブジェクトにしてみたところ、スピードが全然違いました!!
これは超重要事項ですね。
Activate多用は「うおーなんか自動で動いてるー」というのが見える以外、特に使うメリットは多くないんですね。

>VBEのヘルプは状況依存型で、コード内の調査語句にマウスキャレットをあてて[F1]キーを押せば
こ、これは・・・便利すぎます。大変ありがとうございます。
あとエラーチェックや実行時のデバッグも親切で、VBAを作る人の意欲が失われにくくなってると思いました。

>またLoop処理についてはFor...Nextステートメントについて調べてみてください。
使ってみました!ちょっとスッキリしました。あと、一回一回空白かどうか判定する前回の処理よりも、一度データの最終行を取得してループする方がスピードが上がりそうですね。

その他、参照するセルは各ファイルで共通なので、毎回設定を読むのではなく、最初に配列に格納してループ中はそこを見るように変えました。
(「定数式が必要です。」のエラーが多発してくじけそうになりましたが、ReDimを学びました。)

n様には大変お世話になり、改めてお礼申し上げます。

↓以下改良コード↓
-------------------
Sub 抽出実行ボタン()

  ' ↓対象のファイルと、抜き出すセルを設定してあり、マクロの実行ボタンがあるブック
  Dim wb As Workbook
  Set wb = Workbooks("PickCells.xls")
  
  ' ↓一枚目のシートが設定&ボタン
  Dim ws1 As Worksheet
  Set ws1 = wb.Worksheets(1)
  
  ' ↓二枚目のシートに抽出結果を出力する
  Dim ws2 As Worksheet
  Set ws2 = wb.Worksheets(2)
  
  ' ↓開くブックのワーク変数
  Dim wk_wb As Workbook
  Dim wk_ws As Worksheet
  
  
  ' ↓抽出対象のファイルパスが書いてある列
  Dim filePathCol As String
  filePathCol = "B"
  
  ' ↓抽出対象のファイルが列挙してある最初の行
  Dim counter_file As Integer
  counter_file = 8
  
  ' ↓抽出対象のファイルが列挙してある最後の行
  Dim mxRow_file As Integer
  Dim i_file As Integer
  If ws1.Range(filePathCol + CStr(counter_file + 1)).Value <> "" Then
    mxRow_file = ws1.Range(filePathCol + CStr(counter_file)).End(xlDown).Row
  Else
    mxRow_file = counter_file
    ' ↑一行しかない場合End(xlDown)はシート最終行を取得してしまうので
  End If
  
  
  ' ↓抽出対象のセルが列挙してある列
  Dim cellPlaceCol As String
  cellPlaceCol = "D"
  
  ' ↓抽出対象のセルのシートが列挙してある列
  Dim cellSheetPlaceCol As String
  cellSheetPlaceCol = "E"
  
  ' ↓抽出対象のセルが列挙してある最初の行
  Dim counter_cell As Integer
  counter_cell = 8
  
  ' ↓抽出対象のセルが列挙してある最後の行
  Dim mxRow_cell As Integer
  If ws1.Range(cellPlaceCol + CStr(counter_cell + 1)).Value <> "" Then
    mxRow_cell = ws1.Range(cellPlaceCol + CStr(counter_cell)).End(xlDown).Row
  Else
    mxRow_cell = counter_cell
  End If
  
  ' ↓ファイル数の回数繰り返し見ることになるので、予め抽出対象のセルは配列に格納してスピードアップ。
  Dim cellPlaceS() As String
  Dim cellSheetS() As Integer
  ' 変数で配列定義をしようとするとエラーになってしまうのでReDimを使う
  ReDim cellPlaceS(counter_cell To mxRow_cell)
  ReDim cellSheetS(counter_cell To mxRow_cell)
  Dim i As Long
  For i = counter_cell To mxRow_cell
    cellPlaceS(i) = ws1.Range(cellPlaceCol + CStr(i)).Value
    cellSheetS(i) = ws1.Range(cellSheetPlaceCol + CStr(i)).Value
    ' ↓シート番号は空欄だったら1にしておく
    If cellSheetS(i) = 0 Then
      cellSheetS(i) = 1
    End If
  Next i
  
  ' ↓抽出処理開始
  For i_file = counter_file To mxRow_file
    Dim filePath As String
    filePath = ws1.Range(filePathCol + CStr(i_file)).Value
    
    Set wk_wb = Workbooks.Open(Filename:=filePath)

    Dim i_cell As Integer
    For i_cell = LBound(cellPlaceS) To UBound(cellPlaceS)
      Set wk_ws = wk_wb.Worksheets(cellSheetS(i_cell))
      
      Dim targetValue As String
      targetValue = wk_ws.Range(cellPlaceS(i_cell)).Value
      
      ' ↓抽出結果の見出しを作っている部分
      If i_file = counter_file Then
        ws2.Cells(1, i_cell - counter_cell + 1).Value = cellPlaceS(i_cell) + "(" + CStr(cellSheetS(i_cell)) + ")"
      End If
      
      ' ↓ws2に抽出した内容を転記
      ws2.Cells(i_file - counter_file + 2, i_cell - counter_cell + 1).Value = targetValue
    Next i_cell
    
    wk_wb.Close
  Next i_file
  
  ' ↓ReDimしたら後始末が必要らしい
  Erase cellPlaceS
  Erase cellSheetS
  
  ' ↓おまじない
  Set wb = Nothing
  Set ws1 = Nothing
  Set ws2 = Nothing
  Set wk_wb = Nothing
  Set wk_ws = Nothing
End Sub

0 hits

【54777】Workbooksの引数でフルパス指定が原因? jax_6 08/3/29(土) 16:29 質問
【54778】Re:Workbooksの引数でフルパス指定が原因? jax_6 08/3/29(土) 16:43 発言
【54780】Re:Workbooksの引数でフルパス指定が原因? jax_6 08/3/29(土) 17:38 質問
【54781】Re:Workbooksの引数でフルパス指定が原因? n 08/3/29(土) 17:57 発言
【54782】Re:Workbooksの引数でフルパス指定が原因? jax_6 08/3/29(土) 18:32 お礼
【54783】Re:Workbooksの引数でフルパス指定が原因? n 08/3/29(土) 19:27 発言
【54792】Re:Workbooksの引数でフルパス指定が原因? jax_6 08/3/30(日) 12:12 お礼
【54793】Re:Workbooksの引数でフルパス指定が原因? jax_6 08/3/30(日) 12:24 発言

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