Excelのループマクロは早期に終了し、いくつかのループ（異なるファイル）をコピーして開いているファイルを保持する必要が

Question

私はそれが何をしたいのか、このVBAコード

Sub upONGOING_Train1() 
ScreenUpdating = False 
'set variables 
Dim rFndCell As Range 
Dim strData As String 
Dim stFnd As String 
Dim fCol As Integer 
Dim oCol As Integer 
Dim SH As Worksheet 
Dim WS As Worksheet 
Dim strFName As String 
Dim objCell As Object 

Set WS = ThisWorkbook.Sheets("Trains") 
For Each objCell In WS.Range("L3:L100") 
    oCol = objCell.Column 
    strFName = WS.Cells(, oCol).Offset(objCell.Row - 1, 0) 
    On Error GoTo BLANK: 'skip macro if no train 
    Workbooks.Open Filename:=strFName 'open ongoing report 
    Set SH = Worksheets("Trains") 'set sheet 
    stFnd = WS.Cells(, oCol).Offset(objCell.Row - 1, 2).Value 'set connote 
    With SH 
     Set rFndCell = .Range("C3:C1100").Find(stFnd, LookIn:=xlValues) 
     If Not rFndCell Is Nothing Then 
      fCol = rFndCell.Column 
      WS.Cells(, oCol).Offset(objCell.Row - 1, 3).Resize(1, 6).Copy 
      SH.Cells(, fCol).Offset(rFndCell.Row - 1, 10).Resize(1, 6).PasteSpecial xlPasteValues 'paste values in ongoing report if connote found 
      ActiveWorkbook.Save 'save ongoing report 
      ActiveWorkbook.Close 'close ongoing report 
     Else 'Can't find the item 
     End If 
    End With 
BLANK: 
    Next objCell 
ScreenUpdating = True 
End Sub 

に問題のビットを持っていています - L3内のすべての行の：（もし存在または次のいずれかに行をスキップする）カラム「L」に記載されているL100

• ファイルを開き、シートに行く

• 原稿列「N」からマッチ値新たにopeで "C3：C1100"に変更するNEDシート

• コピー列「O：T」と開いたシートに一致する値に対して貼り付け（M：R）、私はそれが与える2行のギャップを残す場合が

を保存私はファイルが見つからないというエラーは、行が1行しかないときのように次のループに進むのではなく、

まだ画像を投稿できません。

また、セル参照でシートを開く方法について誰かが良い方向に向いている場合は、まだ開いていない場合に限り、通常は2つのファイルしか使用できません（四半期の終わりには最大4つ）。 既に開いているブックを再度開くときにポップアップするすべてのウィンドウで[OK]をクリックするのが非常に面倒です。

もしあなたの頭の中にあなたの頭を上げることができれば。 私はすでに2つのクライアント（各四半期毎に新しいので、一度に最大4枚）に2つの別々のレポートを持っています。

すべてのヘルプは大幅に提案し、コードを記述入れている人たちに

おかげヒープ

おかげでいただければ幸いです。 私は明日外出し、失敗しました。私が持っている他のコードを再利用するのは助けになるとは気づいていないという別のアイデアが出てきました。 コードは基本的に空白のタブに必要なものをコピーし、与えられた値を持つ行を削除します - これをソートするのに役立ついくつかの公式では、すべて同じ行先ファイルに改行なしのブロックを与えます。 したがって、もう少し合理化されたありがとうございました）を実行して残りの行をループすることができます。

Answer 1

On Error GoTo BLANK

Workbooks.Open Filename:=strFName

変更上記の本へ：開いているブックを保つHPWするとして、あなたは（なし.close）を開いたままにしておくことができ

On Error Resume Next 
Workbooks.Open Filename:=strFName 
If Err.Number <> 0 Then Goto Blank 

が、その後開いている場合は最初にチェックしてください（つまり、Workbooks("name")を使用しています）、何らかのエラーの手があります上記と同じメカニズムを使用して、エラーが存在し、wbがまだ開いていなければ、それを開きます。

最後に、ActiveWorkbookなどのActiveのものについては数えないようにしてください。代わりに、すなわち、あなたへの明示的な言及はWBます

Set wb = Workbooks.Open(Filename:=strFName) 
Set SH = wb.Worksheets("Trains") 

Answer 2

を非常に少数の限られたケースで使用されるべきであるあなたがRangeオブジェクトのSpecialCells()メソッドを使用して、任意のOn Error GoTo文をオフに残すことができるだけではない空白のセルを、検討します例えば、あなたは、関連するセルを参照するために、いくつかは、無駄に長い息切れ「ループ」を使用している、さらに

（1のうち、我々は秒で表示されます）は：

WS.Cells(, oCol).Offset(objCell.Row - 1, 0) 

に相当しますそれ自身！

• が名前を保存するためにDictionaryオブジェクトを使用します。

  と

  最終的にはそのようないくつかのより多くの例がありますが、あなたはできるオープン/クローズの問題

  のは、ワークブックに来てみましょう開かれたすべてのワークブックのうちマクロ全体を開いたままにして、最後までマクロを閉じます。

• 所望のシートをセットしようとするヘルパー機能を採用する。名前現在objCell値である1すなわち希望ワークブックの「列車」）（）とされていない場合はFalseを返す成功

すべてのものをあなたのコードのリファクタリングこの中に上記：

Sub upONGOING_Train1bis() 
    Dim rFndCell As Range 
    Dim SH As Worksheet 
    Dim objCell As Range 
    Dim shtDict As New Scripting.Dictionary '<--| this is the dictionary that will store every opened workbook name as its 'keys' 
    Dim key As Variant 
' Dim dec As String '<--| do you actually need it? 

    Application.ScreenUpdating = False 
    With ThisWorkbook.Sheets("Trains") '<-- reference your working worksheet 
'  dec = .Range("L1") '<-- what's this for? in any case take it out of for loops since its value doesn't depend on current loop variables 
     For Each objCell In .Range("L3:L100").SpecialCells(xlCellTypeConstants) '<--| loop through L3:L100 range not blank cells only 
      If TrySetWorksheet(objCell.Value, "Trains", SH) Then '<--|Try to set the wanted worksheet in the wanted workbook: if successful it'd retrun 'True' and leave you with 'SH' variable set to the wanted worksheet 
       shtDict(SH.Parent.Name) = shtDict(SH.Parent.Name) + 1 
       Set rFndCell = SH.Range("C3:C1100").Find(objCell.Offset(, 2).Value, LookIn:=xlValues, lookAt:=xlWhole) '<--| specify at least 'LookIn' and 'LookAt' parameters 
       If Not rFndCell Is Nothing Then rFndCell.Offset(, 10).Resize(, 6).Value = objCell.Offset(, 3).Resize(, 6).Value 
      End If 
     Next objCell 
    End With 
    For Each key In shtDict.Keys '<--|loop through opened workbooks dictionary keys 
     Workbooks(key).Close True '<--| close workbook whose name corresponds to current dictionary key 
    Next 
    Application.ScreenUpdating = True 
End Sub 

Function TrySetWorksheet(fileName As String, shtname As String, sht As Worksheet) As Boolean 
    Set sht = Nothing 
    On Error Resume Next 
    Set sht = Workbooks(Right(fileName, Len(fileName) - InStrRev(fileName, "\"))).Worksheets(shtname) '<--| try looking for an already open workbook with wanted name and wanted sheet 
    If sht Is Nothing Then Set sht = Workbooks.Open(fileName:=fileName).Worksheets(shtname) '<--| if not found then try opening the wanted workbook and set the wanted sheet in it 
    TrySetWorksheet = Not sht Is Nothing '<--| set the return value to the final result of attempts at locating the wanted sheet 
End Function