Excel VBA, копируя несколько листов из нескольких файлов в папке на несколько листов в одном файле

Question

Я пытался найти быстрое решение для «слияния» файлов excel, натолкнулось по крайней мере на десяток разных кодов, попытался записать мой собственный макрос и изменяя это (вместо множества имен листов, пытаясь выбрать лот и т. д.) ни один из них не работал нигде рядом с тем, как я этого хотел, большинство из них вообще не работало.

Контекст следующим образом: У меня есть много файлов в папке («C: \ Zoltan \ TEST \»), большинство из которых имеют несколько листов. Я хочу, чтобы скопировать

• все листы, которые не имеют «рассылки» в имени листа
• из всех файлов, которые не имеют «печать» в имени файла
• в один файл (» C: \ Zoltan \ TEST.xlsx "), сохраняя листы отдельно, поскольку они находятся в исходных файлах
• только если имя листа уже существует, я хочу дать ему штамп даты (например, лист под названием« NTI UK »(150) от «E8795 NTI Mailing Order.XLSX», созданного 28 августа 2105 года, чтобы стать «NTI UK (150) 20150828»

Ниже, насколько я понял, что, к сожалению, ничего не делает. В настоящее время я запускаю макрос из открытого файла назначения (что немаловажно, я очень рад, что так оно и есть). Я также по-прежнему отсутствует «Печать» исключение (вместо «рассылки» включения) в имя файла и весь дата штемпеля немного, но это будут мои следующие шаги:

Sub CombineSheets() 
Dim sPath As String 
Dim sFname As String 
Dim wbk As Workbook 
Dim wSht As Worksheet 

Application.EnableEvents = False 
Application.ScreenUpdating = False 
sPath = "C:\Zoltan\TEST\" 
ChDir sPath 
sFname = "*Mailing*" 
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal) 
Do Until sFname = "" 
    Set wbk = Workbooks.Open(sFname) 
    Windows(sFname).Activate 
    For Each ws In Sheets 
     If Not ws.Name Like "*Mailing*" Then ws.Copy Before:=ThisWorkbook.Sheets(1) 
     wbk.Close False 
     sFname = Dir() 
    Next 
Loop 
ActiveWorkbook.Save 
Application.EnableEvents = True 
Application.ScreenUpdating = True 
End Sub 

Я надеюсь, я ве составлена ​​проблема в ясном и легко понять путь, но только, чтобы быть на безопасной стороне, если бы я сделал это вручную, было бы следующее:

1. Открыть файл TEST
2. Открыть источник файл, который не имеет слова «Печать» в имени файла
3. Выделить все листы, которые не имеют «рассылки» в имени листа (это только форма, а не данные листов, мне не нужно)
4. правой кнопки мыши и «Переместить или Копировать», отметьте " Создать копию», выберите TEST.xlsx и выберите Лист1
5. Закрыть исходный файл и перейти к следующему

Обратите внимание, что если выше чистая разделка, что из-за мое отсутствие достаточного VBA навыки. Я, как правило, смотрю коды других людей или записываю макросы, разделяю их, а затем пытаюсь понять их и объединить вместе так, как я хочу, чтобы они работали.

Где я могу пойти не так? Есть ли более простой способ кодировать это? NB. Я бы скорее скопировал целые листы, чем выделил диапазоны в листах и ​​поместил эти диапазоны в новые листы в целевом файле, как и большинство кодов (которые я встретил).

Многие thankZ

Answer 1

Ваш код создает копию листов вы найдете? Вы не объясняете, что именно происходит или нет. У вас есть ваша команда sFname = Dir() в неправильном месте ... И я предлагаю просто автоматически устанавливать имена, а не пытаться выяснить, существует ли имя ...

Имя файла достаточно легко, используйте следующее в вашем цикле сделать:

Set wbk = Workbooks.Open(sFname) 
Windows(sFname).Activate 
For Each ws In Sheets 
    If Not sFname Like "*printing*" Then 
     If Not ws.Name Like "*Mailing*" Then 
      ws.Copy Before:=ThisWorkbook.Sheets(1) 
      ThisWorkbook.Sheets(1).Name = ThisWorkbook.Sheets(1).Name + Format(Now(), "yyyyMMdd-hhmm") 
     End If 
     wbk.Close 
    End If 
Next 
sFname = Dir() 

Answer 2

Некоторые исправления:

Sub CombineSheets() 

    Const sPath As String = "C:\Zoltan\TEST\" 
    Dim sFname As String 
    Dim wbk As Workbook 
    Dim wSht As Worksheet 

    Application.EnableEvents = False 
    Application.ScreenUpdating = False 

    'sPath already has a trailing \ - don't add another... 
    sFname = Dir(sPath & "*Mailing*.xl*", vbNormal) 

    Do Until sFname = "" 

     'Dir only gives you the filename - use full path below 
     Set wbk = Workbooks.Open(sPath & sFname) 

     For Each wSht In wbk.WorkSheets 
      If Not wSht.Name Like "*Mailing*" Then 
       wSht.Copy Before:=ThisWorkbook.Sheets(1) 
      End If 
     Next 
     'moved these lines out of the sheets loop 
     wbk.Close False 
     sFname = Dir() 

    Loop 

    ThisWorkbook.Save 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 

End Sub