HELP!!! Macros на объединение csv файлов в один

[sanych_09]

Доброго времени суток.

есть куча файлов, формат файлов csv. для каждого файла есть свой лист в книге куда он должен быть помещен.

конечно, есть решение простое, открывать каждый файл, копировать всю информацию, находить нужный мне лист, и вставлять.

далеко не программист, но вот такое получилось. на форумах что-то нашел, плюс посмотрел код когда записал макрос

сводный файл находится с текущими csv файлами


почему-то выдает ошибку, что файл не найдет или удален. если можно как-то упростить или отпимизировать работу маскроса, подскажите.

для начала бы разобраться, чтоб он заработал а то может я не там его создал или еще что.

Код
Sub macro_for_copy_paste()

'
' Macro_for_copy_paste Macro
'
my_file = ActiveWorkbook.Name
CuDir = ActiveWorkbook.Path

ChDir CuDir

'''
Workbooks.Open Filename:= _
Dir(CuDir + "\PH1_New_Colocation_DPR_NEW_*.csv" ): ''''' какой файл открыть нужно
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

CSVfilename = ActiveWorkbook.Name
Windows(my_file).Activate
Sheets("PH1_Colocation_DPR").Select : ''''' в какой лист нужно вставить скопированное
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste

Windows(CSVfilename).Activate
Range("A1").Select
Selection.Copy
ActiveWindow.Close

Windows(my_file).Activate

'''
Workbooks.Open Filename:= _
Dir(CuDir + "\PH1_FTK_DPR_NEW_*.csv"): ''''' óêàçûâàþ êàêîé ôàéë íóæíî îòêðûòü.
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

CSVfilename = ActiveWorkbook.Name
Windows(my_file).Activate
Sheets("PH1_FTK_DPR").Select: '''''
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste

Windows(CSVfilename).Activate
Range("A1").Select
Selection.Copy
ActiveWindow.Close

Windows(my_file).Activate

''' и так аналогично для 10 других файликов
'
End Sub

[EducatedFool]

в вашем макросе много лишнего (select и activate)
и вообще, его проще переписать с нуля

посмотрите аналогичный макрос, - можете его взять за основу
http://excelvba.ru/code/CombineFiles

[sanych_09]

Сообщение от EducatedFool

в вашем макросе много лишнего (select и activate)
и вообще, его проще переписать с нуля

посмотрите аналогичный макрос, - можете его взять за основу
http://excelvba.ru/code/CombineFiles

могу только с Вами согласиться,
но к сожалению, не знаю как это сделать (. то что смог, так сказать, раздобыть и пытался в нем разобраться

[IgorGO]

запишите еще 9 правильных имен файлов и названий листов,
уберите комментарии и выполните, помолясь...

Sub macro_for_copy_paste()
  Dim FlNm(10) As String, ShtNm(10) As String, i As Long, CuDir as string
  cudir = ActiveWorkbook.Path & "\"
  FlNm(1) = "PH1_New_Colocation_DPR_NEW_*.csv"
  ShtNm(1) = "PH1_Colocation_DPR"
  ' FlNm(2) = ""
  ' ShtNm(2) = ""
  ' ...
  ' ...
  ' FlNm(10) = ""
  ' ShtNm(10) = ""
  For i = 1 To 10
    ThisWorkbook.Worksheets(ShtNm(i)).Cells.ClearContents
    With Workbooks.Open(cudir & Dir(cudir & FlNm(i))).Worksheets(1).Cells(1)
      .Resize(.End(xlDown).Row, .End(xlToRight).Column).Copy ThisWorkbook.Worksheets(ShtNm(i)).Cells(1)
    End With
    ActiveWorkbook.Close False
  Next
End Sub

[sanych_09]

УВ. ИГОРЬ

СПАСИБО ОГРОМНОЕ! ВСЕ РАБОТАЕТ ЧЕТКО И ПРАВИЛЬНО!

[IgorGO]

макрос можно сделать таким

Sub macro_for_copy_paste()
  Dim i As Long, Cudir As String, fL1 As String, FlNm
  Cudir = ActiveWorkbook.Path & "\"
  Worksheets(1).Columns(2).ClearContents
  FlNm = WorksheetFunction.Transpose(Worksheets(1).UsedRange)
  Worksheets(1).Cells(1, 2).Resize(UBound(FlNm), 1).Value = "ошибка!!! файл не СКОПИРОВАН! (в книге мало листов)"
  For i = 1 To Application.Min(UBound(FlNm), Worksheets.Count - 1)
    fL1 = Dir(Cudir & FlNm(i))
    If fL1 = "" Then
      ThisWorkbook.Worksheets(1).Cells(i, 2) = "ошибка!!! Файл не НАЙДЕН!"
    Else
      ThisWorkbook.Worksheets(i + 1).Cells.ClearContents
      With Workbooks.Open(Cudir & fL1).Worksheets(1).Cells(1)
        .Resize(.End(xlDown).Row, .End(xlToRight).Column).Copy ThisWorkbook.Worksheets(i + 1).Cells(1)
      End With
      ActiveWorkbook.Close False
      ThisWorkbook.Worksheets(1).Cells(i, 2) = ThisWorkbook.Worksheets(i + 1).Name
    End If
  Next
End Sub

для работы макроса предполагается:
1. в исходном файле ЕСТЬ дополнительный лист, он 1-й в списке листов книги
2. 1-я колонка 1-го листа содержит список имен файлов, начиная с ячейки А1
3. на 1-м листе могут быть заполненны только колонка 1 и 2 (А, В) лист не должен содержать БОЛЬШЕ НИ КАКИХ ДАННЫХ
4. перечень листов в книге, начиная с 2-го, соответсвует списку имен файлов на первом листе (листы могут иметь произвольные названия)
5. в случае если листов в книге меньше, чем файлов в списке, или файла нет в папке с программой (имя файла написано с ошибкой), в колонке 2 1-го листа будет соотв. сообщение об ошибке

таким образом Вы сможете управлять работой макроса, добавляя (удаляя) строки с именами файлов на 1-й лист.
после работы макроса на 1-ом листе в колонку В напротив имен файлов будут записаны названия листов, в который были скопированы данные из указанного файла, т.е. 1-й лист выполняет роль источника списка файлов и отчета о проделанной работе

[sanych_09]

Игорь,
спасибо Вам огромное!!! сегодня буду разбираться с новым макросом

я пока не нарадуюсь первой версией.

[IgorGO]

и Вам спасибо!

понятно, вариант 2 - чисто на логике задачи) не представляя тонкостей

а) если изменились названия файлов
б) если изменилось их количество (2 файла, 7, 10, 121... теперь не важно)
в) для изменения списка файлов (количества файлов) - не нужно открывать макрос и переписывать переменные с потонциальной возможностью "поправить" сам макрос до не рабочего состояния
г) в конце-концов вариант 2 на падает по ошибке, если имя файла написано с ошибкой, а сообщает, что такого нет в папке

[sanych_09]

Остановлюсь пока на первом варианте. второй проверил, тоже работает четко! для этого случая нашел макрос, который выдает имена файлов в папке, потом главное сортировку сделать, чтобы первый файл был правильным для 2-го листа

спасибо еще раз! у меня 17 файликов, теперь меньше минуты нужно чтобы скопировать из них всю информацию в один файл

[sanych_09]

Сообщение от IgorGO

запишите еще 9 правильных имен файлов и названий листов,
уберите комментарии и выполните, помолясь...

Sub macro_for_copy_paste()
  Dim FlNm(10) As String, ShtNm(10) As String, i As Long, CuDir as string
  cudir = ActiveWorkbook.Path & "\"
  FlNm(1) = "PH1_New_Colocation_DPR_NEW_*.csv"
  ShtNm(1) = "PH1_Colocation_DPR"
  ' FlNm(2) = ""
  ' ShtNm(2) = ""
  ' ...
  ' ...
  ' FlNm(10) = ""
  ' ShtNm(10) = ""
  For i = 1 To 10
    ThisWorkbook.Worksheets(ShtNm(i)).Cells.ClearContents
    With Workbooks.Open(cudir & Dir(cudir & FlNm(i))).Worksheets(1).Cells(1)
      .Resize(.End(xlDown).Row, .End(xlToRight).Column).Copy ThisWorkbook.Worksheets(ShtNm(i)).Cells(1)
    End With
    ActiveWorkbook.Close False
  Next
End Sub

как вставить скопированные данные в текущую книгу

ThisWorkbook.Worksheets(ShtNm(i)).Cells(1)

только как значения?

пробовал так

With Workbooks.Open(CuDir & Dir(CuDir & FlNm(i))).Worksheets(1).Cells(1)
      .Resize(.End(xlDown).Row, .End(xlToRight).Column).Copy ThisWorkbook.Worksheets(ShtNm(i)).Cells(1).PasteSpecial Paste:=xlPasteValues

выдает ошибку. видимо нужно либо Range указывать... пробовал, тоже не получилось