Добрый день решил создать новую тему, так как вопрос заключается в следующем:
Хочу чтобы чтобы копировались и вставлялись значения которые выбрал сам пользователь, я создал лист бокс с наименованием столбцов, теперь необходимо чтобы выбранные колонки копировались и вставлялись в новый файл, посмотрите пожалуйста так же саму структуру кода, я думаю точно можно что-то сократить или заменить (подробнее в файле примере)
И думаю здесь не помешали бы обработчики ошибок, вы как считаете?
Хочу чтобы чтобы копировались и вставлялись значения которые выбрал сам пользователь, я создал лист бокс с наименованием столбцов, теперь необходимо чтобы выбранные колонки копировались и вставлялись в новый файл, посмотрите пожалуйста так же саму структуру кода, я думаю точно можно что-то сократить или заменить (подробнее в файле примере)
И думаю здесь не помешали бы обработчики ошибок, вы как считаете?
Код |
---|
Sub Test() Dim Dest As Workbook Dim Source As Range Dim ConstFilePath As String Dim ConstFileName As String Dim FileExtStr As String Dim FileFormatNum As Long Dim n As String Dim Path As String Dim arr1 As Variant Dim arr2 As Variant Dim cito As String Dim putin As String 'Создаем два массива для формирования пути к файлам arr1 = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12") arr2 = Array("В.Новгород", "Карелия", "Кубань1", "Кубань2", "Кубань3", "Мари", "Н.Новгород1", "Н.Новгород2", "Н.Новгород3", "Пенза", "Ростов1", "Ростов2", "Ростов3", "Тула", "Ярославль") 'инициализация формы UserForm1.Show q = 0 Path = "\\server6.tns\dzo\56\2018\" cito = "56 2018." MkDir Path & arr2(q) For i = 0 To 9 'создаем путь к файлу который будет открыт putin = Path & cito & arr1(i) & " " & arr2(q) & ".xlsx" 'открываем файл Workbooks.Open (putin) Application.DisplayAlerts = False ' Тут вместо значений А В С... нужно чтобы подбирались выбранные пользователем значения, и с этими значениями выполнялось копирование и вставка в новый файл 'A = WorksheetFunction.Match("TypeDoma", [ФЛ_Ф_056!a1:ww1], 0) 'B = WorksheetFunction.Match("TypUL", [ФЛ_Ф_056!a1:ww1], 0) 'C = WorksheetFunction.Match("LS", [ФЛ_Ф_056!a1:ww1], 0) 'j = WorksheetFunction.Match("VOL_IND", [ФЛ_Ф_056!a1:ww1], 0) 'D = WorksheetFunction.Match("N_SERV", [ФЛ_Ф_056!a1:ww1], 0) 'E = WorksheetFunction.Match("SQUARE", [ФЛ_Ф_056!a1:ww1], 0) 'F = WorksheetFunction.Match("ROOMS", [ФЛ_Ф_056!a1:ww1], 0) 'G = WorksheetFunction.Match("MAN_COUNT", [ФЛ_Ф_056!a1:ww1], 0) 'H = WorksheetFunction.Match("STATUS", [ФЛ_Ф_056!a1:ww1], 0) Set Source = Nothing On Error Resume Next 'изменить данную процедуру на выделение диапазонов выбранных из ListBox Set Source = Union(Columns(A), Columns(B), Columns(C), Columns(j), Columns(D), Columns(E), Columns(F), Columns(G), Columns(H)) On Error GoTo 0 'копируем и вставляем выделенные диапазоны на нвоый лист Set Dest = Workbooks.Add(xlWBATWorksheet) Source.Copy With Dest.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial Paste:=xlPasteValues .Cells(1).Select Application.CutCopyMode = False End With 'сохраняем под новым именем With Dest .SaveAs Path & arr2(q) & "\" & cito & arr1(i) & ".xlsx" On Error Resume Next End With 'это я не знаю что Dest.Close savechanges:=True Application.DisplayAlerts = True 'закрываем книгу ThisWorkbook.Close 'переходим на следующий файл Next i End Sub |