マスターシートにループするときの値の貼り付け

Question

誰かが私を助けるためにとても親切であるかどうか疑問に思っていました。私はまだVBAをかなり新しくしており、いくつかの人が使用するいくつかのデータシートをループするコードを作成しました。

Dim MyFile As String 
Dim erow 
MyFile = Dir("C:\My Documents\Tester") 

Workbooks.Open ("C:\My Docments\Tester\TestLog.xlsm") 

Sheets("Master").Select 
Rows("2:2").Select 
Range(Selection, Selection.End(xlDown)).Select 
Selection.Delete Shift:=xlUp 
Application.DisplayAlerts = False 

Do While Len(MyFile) > 0 
    If MyFile = "ZMaster - Call Log.xlsm" Then 
    Exit Sub 
    End If 

    Workbooks.Open (MyFile) 
    Application.DisplayAlerts = False 
    Sheets("Calls").Activate 
    Range("A2:P2").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 

    ActiveWindow.Close savechanges:=False 

    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 
    ActiveSheet.Paste Destination:=Worksheets("Master").Range(Cells(erow, 1), Cells(erow, 16)) 

ここに2つの問題があります。最初にループ内の最初のブックが自分で「別名で保存」されていない限り、マクロは失敗します。保存されません。最初のブックを開く場合は、同じファイル名で保存をクリックして、動作するマクロを再生します。私は最初のワークブックを開いて、それを介して保存するマクロによって、少し厄介な少しの作業を開発しましたが、そうすることはありません。

第2の最も重要なのは第2です。他のブックからZmasterに私の情報を得るとき、私のサブブックはすべて英語の形式の日付を持っています。しかし、Zmasterに貼り付けるときには、01/12/16ではなく12/01/16として渡ります。いかなる援助も感謝します。

Answer 1

私は「フォルダー内の複数のファイルを選別する」スクリプトを何度も繰り返し使用しています。

はまた、代わりにコピー＆ペーストの

Sub Theloopofloops() 

Dim wbk As Workbook 
Dim Filename As String 
Dim path As String 
Dim rCell As Range 
Dim rRng As Range 
Dim wsO As Worksheet 
Dim sheet As Worksheet 


path = "pathtofile(s)" & "\" 
Filename = Dir(path & "*.xl??") 
Set wsO = ThisWorkbook.Sheets("Sheet1") 'included in case you need to differentiate_ 
       between workbooks i.e currently opened workbook vs workbook containing code 

Do While Len(Filename) > 0 
    DoEvents 
    Set wbk = Workbooks.Open(path & Filename, True, True) 
     For Each sheet In ActiveWorkbook.Worksheets 'this needs to be adjusted for specifiying sheets. Repeat loop for each sheet so thats on a per sheet basis 
       Set rRng = sheet.Range("a1:a1000") 'OBV needs to be changed 
       For Each rCell In rRng.Cells 
       If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then 

        'code that does stuff 
        wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell 
        wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 1).Value = rCell.Offset(0, -1) 
        wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 2).Value = Mid(Right(ActiveWorkbook.FullName, 15), 1, 10) 

       End If 
       Next rCell 
     Next sheet 
    wbk.Close False 
    Filename = Dir 
Loop 
End Sub