ファイルが開いていない場合は、次へ進む

Question

複数のワークブックから、1つのワークブックに情報をコピーします。これは魅力のように機能します。私はちょうど数週間後にデータをコピーするために別のファイルを追加する必要があることを知った。私は今マクロを取得したいと思っていましたが、新しいワークブックを開いていないと、マクロは止まらなくなります。私はいくつかの方法で試しましたが、うまく動作しません。 他の3つのブックと同じコードを使用していますので、これが来たら、ブックが開いていなければマクロをスキップします。 提案がありますか？

Windows("filename.xlsx").Activate 
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy 
Workbooks("Masterfile.xlsm").Sheets("Electra").Activate 
Range("A2").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 

Answer 1

このコードでは、開いているワークブックを確認し、必要なファイル名の一覧を確認します。

発生する可能性がある問題がいくつかあります：

コードはこれをチェックしないとワークブックはSheet1と呼ばれるシートを持っている必要があります。

book1.xlsmと1book1.xlsmというファイルがある場合は、両方でbook1.xlsmが発生します。

カラムA:Kの最後のセルを見つけることが改善されました。現在、A2から列Kのデータを含む最後の行に移動します。

すべての情報はセルA2から貼り付けられます。 Electraシートの最後の行を見つけるコードが必要です。

Sub Test() 

    Dim sFileNames As String 
    Dim wrkBk As Workbook 

    sFileNames = "Somebook.xls, book1.xlsm, book2.xlsx" 

    For Each wrkBk In Workbooks 
     If InStr(UCase(sFileNames), UCase(wrkBk.Name)) > 0 Then 
      With wrkBk.Worksheets("Sheet1") 
       .Range(.Cells(2, 1), .Cells(.Rows.Count, 11).End(xlUp)).Copy 
       ThisWorkbook.Worksheets("Electra").Range("A2").PasteSpecial xlPasteValues 
      End With 
     End If 
    Next wrkBk 

End Sub 

編集：
MasterFileに異なるシートに一つの選択肢をペーストには、ブック&先のシートのペアを保持するために辞書を使用することです。

このコードは、ファイル名をキーとして、宛先シートを値として追加します。次に、ワークブック名​​がディクショナリ内に存在するかどうかを確認します。ワークブック名​​がSheet1のデータをコピーし、値を関連するシートに貼り付けます。

Sub Test() 

    Dim dict As Object 
    Dim wrkBk As Workbook 
    Set dict = CreateObject("Scripting.Dictionary") 

    dict.CompareMode = vbTextCompare 
    dict.Add "Book2.xlsx", "Sheet1" 
    dict.Add "Book3.xlsx", "Sheet2" 

    For Each wrkBk In Workbooks 
     If dict.exists(wrkBk.Name) Then 
      With wrkBk.Worksheets("Sheet1") 
       .Range(.Cells(2, 1), .Cells(.Rows.Count, 11).End(xlUp)).Copy 
       ThisWorkbook.Worksheets(dict(wrkBk.Name)).Range("A2").PasteSpecial xlPasteValues 
      End With 
     End If 
    Next wrkBk 

End Sub 

編集2：
ソースワークブックがすべて開始時に閉鎖されている場合は、その後、該当するファイルを開くに情報をコピーして、再度ファイルを閉じるには、このコードを使用します。

Sub Test() 

    Dim dict As Object 
    Dim wrkBk As Workbook 
    Dim vItem As Variant 
    Dim sPath As String 

    'All workbooks to open will be in this folder. 
    'Remember to include the final back-slash (\). 
    sPath = "C:\Test\" 

    Set dict = CreateObject("Scripting.Dictionary") 

    dict.CompareMode = vbTextCompare 

    'If files will not all be in the same folder, then 
    'full file path must be included here and remove 
    'references to sPath variable in the code. 
    dict.Add "Book2.xlsx", "Sheet1" 
    dict.Add "Book3.xlsx", "Sheet2" 

    For Each vItem In dict 
     Set wrkBk = Workbooks.Open(sPath & vItem) 
     With wrkBk.Worksheets("Sheet1") 
      .Range(.Cells(2, 1), .Cells(.Rows.Count, 11).End(xlUp)).Copy 
      ThisWorkbook.Worksheets(dict(wrkBk.Name)).Range("A2").PasteSpecial xlPasteValues 
     End With 
     wrkBk.Close SaveChanges:=False 
    Next vItem 

End Sub 

Answer 2

これは実際に働いたことがありますが、私は決して電話をしませんでしたので、試してみました。私は開いている別の本とこの複数の時間を実行することができますし、バグアウトや物事を台無しにしないでください。 2つのテストが行​​われる限り、それほど面倒ではありません。 サブSteg11（） ' ' Steg1マクロ

'Macrot flyttarデータフランCDPPT FIL MEDförsäljningsdata、 ' フランFIL MED ElectrasförsäljningOCH FIL MED produktdata。 「Kopierar formler、rensarförsäljningLagerhållare

まで

Dim MainWkbk As Workbook 
Dim NextWkbk As Workbook 
Set MainWkbk = ActiveWorkbook 
Set NextWkbk = ActiveWorkbook 

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 
Application.DisplayStatusBar = False 
Application.EnableEvents = False 
ActiveSheet.DisplayPageBreaks = False 

' Letar in CDPPT, lägger in formler, sorterar bladet. 
On Error GoTo 3 
Windows("CDPPT.xlsx").Activate 
Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Copy 
Workbooks("Datamatchningsfil.xlsm").Sheets("CDPPT").Activate 
Range("A2").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 

Sheets("CDPPT").Select 
Range(Range("I2"), Range("I2").End(xlToRight)).Copy 
Range("H2").Select 
Selection.End(xlDown).Select 
ActiveCell.Offset(0, 1).Select 
Range(Selection, Selection.End(xlUp)).Offset(1, 0).Select 
ActiveSheet.Paste 

Application.Goto Sheets("CDPPT").Range("A:M") 
Selection.Sort Key1:=Range("E1"), Order1:=xlDescending, Header:=xlGuess, _ 
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
DataOption1:=xlSortNormal 


'Tar bort data där telia inte ska betala skatt 
Application.Goto Sheets("CDPPT").Range("E1") 
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*BRIGHTSTAR*" _ 
    , Operator:=xlAnd 
ActiveCell.Offset(1, 0).Activate 
Range(Selection, Selection.End(xlDown)).Select 
Selection.EntireRow.Delete 
ActiveSheet.ShowAllData 
ActiveWorkbook.RefreshAll 
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*ELECTRA*" _ 
    , Operator:=xlAnd 
ActiveWindow.SmallScroll Down:=-6 
ActiveCell.Offset(1, 0).Activate 
Range(Selection, Selection.End(xlDown)).Select 
Selection.EntireRow.Delete 
ActiveSheet.ShowAllData 
ActiveWorkbook.RefreshAll 
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*Ingram*" _ 
    , Operator:=xlAnd 
ActiveWindow.SmallScroll Down:=-9 
ActiveCell.Offset(1, 0).Activate 
Range(Selection, Selection.End(xlDown)).Select 
Selection.EntireRow.Delete 
ActiveSheet.ShowAllData 
ActiveWorkbook.RefreshAll 
ActiveSheet.Range("$A:$M").AutoFilter Field:=3, Criteria1:="=*brev*" _ 
    , Operator:=xlAnd 
ActiveCell.Offset(1, 0).Activate 
Range(Selection, Selection.End(xlDown)).Select 
Selection.EntireRow.Delete 
ActiveSheet.ShowAllData 
ActiveWorkbook.RefreshAll 
ActiveSheet.Range("$A:$M").AutoFilter Field:=3, Criteria1:="=*Konfig*" _ 
    , Operator:=xlAnd 
ActiveCell.Offset(1, 0).Activate 
Range(Selection, Selection.End(xlDown)).Select 
Selection.EntireRow.Delete 
ActiveSheet.ShowAllData 
ActiveWorkbook.RefreshAll 
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*(Manuellt 
inmatad)*" _ 
    , Operator:=xlAnd 
ActiveCell.Offset(1, 0).Activate 
Range(Selection, Selection.End(xlDown)).Select 
Selection.EntireRow.Delete 
ActiveSheet.ShowAllData 
ActiveWorkbook.RefreshAll 

3 
Call Produktdata 
End Sub 

Sub Produktdata() 

'Letar in produktdata 
On Error GoTo 4 
Windows("Produktdata.xlsx").Activate 
If ActiveSheet.AutoFilterMode Then Cells.AutoFilter 
Range(Range("A:J"), Range("A:J").End(xlDown)).Copy 
Workbooks("Datamatchningsfil.xlsm").Sheets("Produktdata").Activate 
Range("A1").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
4 
Call Electra 
End Sub 

Sub Electra() 
'Letar in data från Lagerhållare 
On Error GoTo 5 
Windows("Electra sales.xlsx").Activate 
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy 
Workbooks("Datamatchningsfil.xlsm").Sheets("Electra").Activate 
Range("A2").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
5 
Call TalkTelecom 
End Sub 

Sub TalkTelecom() 

'Letar in data från Lagerhållare 
On Error GoTo 6 
Windows("TalkTelecom.xlsx").Activate 
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy 
Workbooks("Datamatchningsfil.xlsm").Sheets("TalkTelecom").Activate 
Range("A2").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
6 
Call Techdata 
End Sub 

Sub Techdata() 
'Letar in data från Lagerhållare 
On Error GoTo 7 
Windows("TechData.xlsx").Activate 
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy 
Workbooks("Datamatchningsfil.xlsm").Sheets("TechData").Activate 
Range("A2").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
7 
Call Continue 
End Sub 

Sub Continue() 

' Utför text till kolumn 
Application.Goto Sheets("Produktdata").Range("C:C") 
Columns("C:C").Select 
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ 
    :=Array(1, 1), TrailingMinusNumbers:=True 

Application.Goto Sheets("CDPPT").Range("F:F") 
Columns("F:F").Select 
Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ 
    :=Array(1, 1), TrailingMinusNumbers:=True 

Application.Calculation = xlCalculationAutomatic 
ActiveWorkbook.RefreshAll 

'Lägger in år och månad i blad arbetsbeskrivning 
Application.Goto Sheets("CDPPT").Range("G2") 
Range("G2").Copy 
Sheets("Arbetsbeskrivning").Select 
Range("C10").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Range("D10").Activate 
Application.CutCopyMode = False 
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-1],2)" 
Range("D10").Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Range("D10").Select 
Selection.TextToColumns Destination:=Range("D10"), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ 
    :=Array(1, 1), TrailingMinusNumbers:=True 
Range("D9").Activate 
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[1]C,Datalistor!R[-6]C[1]:R[5]C[2],2,0)" 
Range("C9").Activate 
ActiveCell.FormulaR1C1 = "=Left(R[1]C,4)" 
Range("C4").Activate 


' kopierar data och skapar Pivotdata Telia försäljning 
Sheets("CDPPT").Select 
Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Copy 
Destination:=Sheets("Matchning"). _ 
    Range("A2") 
Application.CutCopyMode = False 
Sheets("CDPPT").Select 
Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Copy 
Destination:=Sheets("Pivotgrund"). _ 
    Range("A2") 
Application.CutCopyMode = False 

ActiveWorkbook.RefreshAll 

' Tar bort dubletter 
Application.Goto Sheets("Matchning").Range("A:M") 
Selection.Sort Key1:=Range("F1"), Order1:=xlDescending, Header:=xlGuess, _ 
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
DataOption1:=xlSortNormal 
Application.Goto Sheets("Matchning").Range("A1") 
Range(Range("A1"), Range("A1").End(xlToRight).End(xlDown)).Select 
ActiveSheet.Range("A:L").RemoveDuplicates Columns:=6, Header:= _ 
    xlYes 

ActiveWorkbook.RefreshAll 

' letar in Pivotdata 
Application.Goto Sheets("Matchning").Range("H2") 
ActiveCell.FormulaR1C1 = "=VLOOKUP(C[-2],Pivot!C[-7]:C[-6],2,0)" 
Range("H2").Select 
Selection.Copy 
Range(Selection, Selection.End(xlDown)).Select 
ActiveSheet.Paste 

ActiveWorkbook.RefreshAll 

' Skapar fil med prod med saknad data 
Application.Goto Sheets("Matchning").Range("A1") 
Range("A1").Select 
ActiveSheet.Range("$A:P").AutoFilter Field:=12, Criteria1:= _ 
    "Check for data" 
Range(Range("A1"), Range("A1").End(xlToRight).End(xlDown)).Copy 
Range("A1").Select 
Workbooks.Add 
ActiveSheet.Paste 
ActiveWorkbook.Windows(1).Caption = "Produktdata saknas" 
Columns("M:P").Select 
Selection.Delete Shift:=xlToLeft 
Range("A1").Select 

Windows("Datamatchningsfil.xlsm").Activate 
Application.Goto Sheets("Matchning").Range("A1") 
ActiveSheet.ShowAllData 


ActiveWorkbook.RefreshAll 
Application.ScreenUpdating = True 

Sheets("Arbetsbeskrivning").Select 
Range("C13").Select 
With Selection.Font 
    .Color = -16776961 
    .TintAndShade = 0 
End With 
Selection.Font.Bold = True 
ActiveCell.FormulaR1C1 = _ 
    "Steg 1 klart!" 
Range("C14").Select 


Application.DisplayStatusBar = True 
Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 

MsgBox ("Steg 1 klart") 

End Sub