Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Перенос данных из нескольких книг в одну, c заданной ячейк., Доработка существующего макроса.
 
#1
27.12.2019 10:24:40
Добрый день, на данном форуме был макрос по копированию листов из выбранных книг в текущую.

Подскажите пожалуйста, как корректно изменить код так, чтобы он копировал указанный диапазон (например, А1:A13) со всех листов1 указанного набора книг в текущую книгу, но делал это в выделенную мной ячейку. Н-р: из первых двух книг данные копируются в столбцы A,B.
А при каждом добавлении новых книг, данные копировались бы, начиная со следующего столбца С,D,E..... И т.д.
Код
Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer

Application.ScreenUpdating = False 'отключаем обновление экрана для скорости

'вызываем диалог выбора файлов для импорта
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:="Files to Merge")

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!"
Exit Sub
End If

'проходим по всем выбранным файлам
x = 1
While x <= UBound(FilesToOpen)
Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
importWB.Close savechanges:=False
x = x + 1
Wend

Application.ScreenUpdating = True
End Sub
 
 
 
#2
27.12.2019 10:33:49
Код
'Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(1)
    Set r = .Cells(1, .Columns.Count).End(xlToLeft).Cells(1, 2)
End With
Sheets(1).Range("A1:A13").Copy r
 
 
 
#3
27.12.2019 11:27:41
cdj100, оформите код тегом <...>, что б было как у МатросНаЗебре,
 
 
 
#4
27.12.2019 13:41:25
Подскажите пжлст как будет выглядеть окончательный код?
Пробую несколько варинатов - иксель виснет. С макросами делаю первые шаги, строго прошу не судить.  
Код
Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
 
    Application.ScreenUpdating = False  '????????? ?????????? ?????? ??? ????????
     
    '???????? ?????? ?????? ?????? ??? ???????
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
 
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "?? ??????? ?? ?????? ?????!"
        Exit Sub
    End If
     
    '???????? ?? ???? ????????? ??????
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        'Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(1)
    Set r = .Cells(1, .Columns.Count).End(xlToLeft).Cells(1, 2)
End With
Sheets(1).Range("A1:A13").Copy r
    Wend
 
    Application.ScreenUpdating = True
End Sub
 
 
 
#5
27.12.2019 13:47:31
Код
''???????? ?? ???? ????????? ??????
'    x = 1
'    While x <= UBound(FilesToOpen)
'        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
'        'Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'With ThisWorkbook.Sheets(1)
'    Set r = .Cells(1, .Columns.Count).End(xlToLeft).Cells(1, 2)
'End With
'Sheets(1).Range("A1:A13").Copy r
'    Wend
      
    For x = LBound(FilesToOpen) To UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        'Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        With ThisWorkbook.Sheets(1)
            Set r = .Cells(1, .Columns.Count).End(xlToLeft).Cells(1, 2)
        End With
        Sheets(1).Range("A1:A13").Copy r
        importWB.Close False
    Next
 
 
 
#6
27.12.2019 13:59:37
Работает  :D !!!  
Но почему-то копирует только первый символ из диапазона А1-А13, тогда как в каждой ячейке их около 50.
Подскажите, что в коде нужно изменить?
 
 
 
#7
27.12.2019 14:08:37
А выложите файл. Желательно в формате xlsx, в смысле не xlsm и не xlsb.
Файл, из которого копируете.
Изменено: МатросНаЗебре - 27.12.2019 14:09:05
 
 
 
#8
27.12.2019 14:43:49
Пожалуйста: текущий файл и две книги .csv

P.S. также обратил внимание, что копирует данные по умолчанию в следующий столбец, а не в выделенную мной ячейку.
Это не совсем удобно, так как иногда необходимо копировать в любую выделенную ячейку.
Можно ли это скорректировать?
 
 
 
#9
27.12.2019 14:51:25
Цитата
cdj100 написал:
Но почему-то копирует только первый символ из диапазона А1-А13, тогда как в каждой ячейке их около 50.
Эту ошибку повторить не смог.
 
 
 
#10
27.12.2019 14:54:38
Код
Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
  
    Application.ScreenUpdating = False
      
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
  
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "?? ??????? ?? ?????? ?????!"
        Exit Sub
    End If
      
    Dim importWB As Workbook
    Dim r As Range
    Set r = Selection.Cells(1)
    For x = LBound(FilesToOpen) To UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        Sheets(1).Range("A1:A13").Copy r
        importWB.Close False
        Set r = r.Cells(1, 2)
    Next
    
    Application.ScreenUpdating = True
End Sub
Так будет копировать в выделенную ячейку.
 
 
 
#11
27.12.2019 15:22:43
Спасибо огромное, с ячейкой все отлично работает  

Но вот символы по-прежнему не выходят в полном составе. Подскажите, что может быть не так!?
 
 
 
#12
27.12.2019 15:27:47
Код
Sheets(1).Range("A1:O13").Copy r
        
Увеличьте количество столбцов.
 
 
 
#13
27.12.2019 15:53:47
Получается вот такой результат:
Изменено: cdj100 - 27.12.2019 15:57:17
 
 
 
#14
27.12.2019 15:54:14
А хотелось бы таким образом:
Изменено: cdj100 - 27.12.2019 15:54:31
 
 
 
#15
30.12.2019 09:58:08
Код
Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
  
    Application.ScreenUpdating = True
      
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
  
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "?? ??????? ?? ?????? ?????!"
        Exit Sub
    End If
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim importWB As Workbook
    Dim rFrColumnsCount As Integer
    Dim rFr As Range
    Dim rTo As Range
    Set rTo = Selection.Cells(1)
    Dim y As Long
    For x = LBound(FilesToOpen) To UBound(FilesToOpen)
        y = 1
        Select Case LCase(fso.GetExtensionName(FilesToOpen(x)))
        Case "txt", "csv"
            With fso.OpenTextFile(FilesToOpen(x), 1, False)
                Do
                    If .AtEndOfStream Then Exit Do
                    rTo.Cells(y, 1).Value = .ReadLine
                    y = y + 1
                Loop
                .Close
            End With
            Set rTo = rTo.Offset(0, 1)
        Case Else
            Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
            Set rFr = Sheets(1).Range("A1:O13")
            rFr.Copy rTo
            rFrColumnsCount = rFr.Columns.Count
            importWB.Close False
            Set rTo = rTo.Offset(0, rFrColumnsCount)
        End Select
    Next
    
    Application.ScreenUpdating = True
End Sub
 
 
 
Страницы: 1
Наверх