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个问题。首先，宏失败，除非循环中的第一个工作簿是＆＃34; Saved As＆＃34;我自己。不保存仅保存为。如果我打开第一个工作簿，单击相同文件名下的保存，然后播放它工作的宏。我已经开发了一个令人讨厌的小工作，通过宏打开第一个工作簿并保存为通过，但宁愿不这样做。

第二也是最重要的。当我从其他工作簿获取我的信息到Zmaster我的子工作簿都有英文格式的日期。然而，当粘贴到Zmaster时，它将在2016年12月1日而不是2016年12月1日发生。任何帮助将不胜感激。

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

循环到主工作表时粘贴值

1 个答案: