遍历工作表以将 dd/mm/yy 格式的日期值粘贴到主工作表中

Question

我有代码可以遍历几张数据。

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))

我有两个问题。

首先，除非循环中的第一个工作簿是我自己“另存为”，否则宏会失败。未保存仅另存为。如果我打开第一个工作簿，请单击相同文件名下的另存为，然后运行它可以工作的宏。我通过宏打开第一个工作簿并另存为来开发了一个解决方法。

其次，也是最重要的。我的子工作簿都有英文格式的日期。但是，当粘贴到 Zmaster 时，它会显示为 12/01/16 而不是 01/12/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