Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Копирование диапазона - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование диапазона (Макросы/Sub)
Копирование диапазона
Elhust Дата: Среда, 26.04.2017, 09:40 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 158
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
Доброго времени суток уважаемые специалисты и просто гуру Excel
Есть у меня код по копированию данных из книг которые лежат в папке
То есть выбираем папку и все книги начинает перебирать но чёт я такую тупость словил и прошу вашей помощи
не получается копировать диапазон ... это тупик какой то одни ошибки ..
[vba]
Код

Sub All_File4()
    Dim sh As Worksheet, wsDataSheet As Object, lLastCol As Long
    Dim sFolder As String, sFiles As String, FileMask As String
    Dim iCell1 As Range, iCell2 As Range, iCell3 As Range, iCell11 As Range, iCell13 As Range, iCell15 As Range, iCell17 As Range
    Dim iCell19 As Range
'--------------------------------Откл.Обновление связей и экрана----------------------------------------
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: .DisplayAlerts = False: .AskToUpdateLinks = False
.PrintCommunication = False: '.ActivePrinter = "*Brother*DCP-L5500DN*series*" '.Dialogs (xlDialogPrinterSetup)
End With
'-------------------------------------------------------------------------------------------------------
Set wsDataSheet = ActiveWorkbook.Sheets("Обратная связь не экспресс") 'Лист на который вставляются значения
lLastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
'-------------------------------------------------------------------------------------------------------
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
'-----------------------------------Открываем книгу-----------------------------------------------------
FileMask = "*.xls*"
    sFiles = Dir(sFolder & FileMask)
Do While sFiles <> ""
        'открываем книгу
        Workbooks.Open Filename:=sFolder & sFiles
'        On Error Resume Next
'---------------------------------------Цикл по листам--------------------------------------------------
For Each sh In Worksheets
'-------------------------------------------------------------------------------------------------------
'Лист на котором производиться поиск
If InStr(sh.Name, "Обратная связь") Then
MsgBox "ok"
'-------------------------------------------------------------------------------------------------------
Set iCell1 = sh.Range("B4").Value
Set iCell2 = sh.Range("B5").Value
Set iCell3 = sh.Range("B6").Value
Set iCell11 = sh.Range("D10:E10").Value
'iCell12 = sh.Range("E10").Value
Set iCell13 = sh.Range("D11:E11").Value
'iCell14 = sh.Range("E11").Value
Set iCell15 = sh.Range("D12:E12").Value
'iCell16 = sh.Range("E12").Value
Set iCell17 = sh.Range("D13:E13").Value
'iCell18 = sh.Range("E13").Value
Set iCell19 = sh.Range("D14:E14").Value
'iCell110 = sh.Range("E14").Value (Cells(1, 1), Cells(10, 1))
'MsgBox "ok"
'-------------------------------------------Вставка данных на лист вывода--------------------------------
'     wsDataSheet.Range(Cells(1, lLastCol), Cells(1, lLastCol + 1)).Value = iCell1
'     wsDataSheet.Range(Cells(2, lLastCol), Cells(2, lLastCol + 1)).Value = ActiveWorkbook.Path
'     wsDataSheet.Range.Cells(4, lLastCol).Value = iCell2
'     wsDataSheet.Range.Cells(3, lLastCol).Value = iCell3
MsgBox "ok"
     wsDataSheet.Range(Cells(6, lLastCol), Cells(6, lLastCol + 1)).Value = iCell11
''     wsDataSheet.Cells(6, lLastCol).Value = iCell12
'     wsDataSheet.Range.Cells(7, lLastCol).Value = iCell13
''     wsDataSheet.Cells(7, lLastCol).Value = iCell14
'     wsDataSheet.Range.Cells(8, lLastCol).Value = iCell15
''     wsDataSheet.Cells(8, lLastCol).Value = iCell16
'     wsDataSheet.Range.Cells(9, lLastCol).Value = iCell17
''     wsDataSheet.Cells(9, lLastCol).Value = iCell18
'     wsDataSheet.Range.Cells(10, lLastCol).Value = iCell19
''     wsDataSheet.Cells(10, lLastCol).Value = iCell110
     lLastCol = lLastCol + 1
'-------------------------------------------------------------------------------------------------------
End If
Next sh
'----------------------------------------Закрываем книгу------------------------------------------------
        ActiveWorkbook.Close False 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
Loop
'--------------------------------Вкл.Обновление связей и экрана-----------------------------------------
With Application
lCalc = .Calculation
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc: .DisplayAlerts = True: .AskToUpdateLinks = True
.PrintCommunication = True: '.ActivePrinter = "*Brother*DCP-L5500DN*series*" '.Dialogs (xlDialogPrinterSetup)
End With
End Sub
[/vba]


Каждый сам выбирает правила игры
 
Ответить
СообщениеДоброго времени суток уважаемые специалисты и просто гуру Excel
Есть у меня код по копированию данных из книг которые лежат в папке
То есть выбираем папку и все книги начинает перебирать но чёт я такую тупость словил и прошу вашей помощи
не получается копировать диапазон ... это тупик какой то одни ошибки ..
[vba]
Код

Sub All_File4()
    Dim sh As Worksheet, wsDataSheet As Object, lLastCol As Long
    Dim sFolder As String, sFiles As String, FileMask As String
    Dim iCell1 As Range, iCell2 As Range, iCell3 As Range, iCell11 As Range, iCell13 As Range, iCell15 As Range, iCell17 As Range
    Dim iCell19 As Range
'--------------------------------Откл.Обновление связей и экрана----------------------------------------
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: .DisplayAlerts = False: .AskToUpdateLinks = False
.PrintCommunication = False: '.ActivePrinter = "*Brother*DCP-L5500DN*series*" '.Dialogs (xlDialogPrinterSetup)
End With
'-------------------------------------------------------------------------------------------------------
Set wsDataSheet = ActiveWorkbook.Sheets("Обратная связь не экспресс") 'Лист на который вставляются значения
lLastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
'-------------------------------------------------------------------------------------------------------
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
'-----------------------------------Открываем книгу-----------------------------------------------------
FileMask = "*.xls*"
    sFiles = Dir(sFolder & FileMask)
Do While sFiles <> ""
        'открываем книгу
        Workbooks.Open Filename:=sFolder & sFiles
'        On Error Resume Next
'---------------------------------------Цикл по листам--------------------------------------------------
For Each sh In Worksheets
'-------------------------------------------------------------------------------------------------------
'Лист на котором производиться поиск
If InStr(sh.Name, "Обратная связь") Then
MsgBox "ok"
'-------------------------------------------------------------------------------------------------------
Set iCell1 = sh.Range("B4").Value
Set iCell2 = sh.Range("B5").Value
Set iCell3 = sh.Range("B6").Value
Set iCell11 = sh.Range("D10:E10").Value
'iCell12 = sh.Range("E10").Value
Set iCell13 = sh.Range("D11:E11").Value
'iCell14 = sh.Range("E11").Value
Set iCell15 = sh.Range("D12:E12").Value
'iCell16 = sh.Range("E12").Value
Set iCell17 = sh.Range("D13:E13").Value
'iCell18 = sh.Range("E13").Value
Set iCell19 = sh.Range("D14:E14").Value
'iCell110 = sh.Range("E14").Value (Cells(1, 1), Cells(10, 1))
'MsgBox "ok"
'-------------------------------------------Вставка данных на лист вывода--------------------------------
'     wsDataSheet.Range(Cells(1, lLastCol), Cells(1, lLastCol + 1)).Value = iCell1
'     wsDataSheet.Range(Cells(2, lLastCol), Cells(2, lLastCol + 1)).Value = ActiveWorkbook.Path
'     wsDataSheet.Range.Cells(4, lLastCol).Value = iCell2
'     wsDataSheet.Range.Cells(3, lLastCol).Value = iCell3
MsgBox "ok"
     wsDataSheet.Range(Cells(6, lLastCol), Cells(6, lLastCol + 1)).Value = iCell11
''     wsDataSheet.Cells(6, lLastCol).Value = iCell12
'     wsDataSheet.Range.Cells(7, lLastCol).Value = iCell13
''     wsDataSheet.Cells(7, lLastCol).Value = iCell14
'     wsDataSheet.Range.Cells(8, lLastCol).Value = iCell15
''     wsDataSheet.Cells(8, lLastCol).Value = iCell16
'     wsDataSheet.Range.Cells(9, lLastCol).Value = iCell17
''     wsDataSheet.Cells(9, lLastCol).Value = iCell18
'     wsDataSheet.Range.Cells(10, lLastCol).Value = iCell19
''     wsDataSheet.Cells(10, lLastCol).Value = iCell110
     lLastCol = lLastCol + 1
'-------------------------------------------------------------------------------------------------------
End If
Next sh
'----------------------------------------Закрываем книгу------------------------------------------------
        ActiveWorkbook.Close False 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
Loop
'--------------------------------Вкл.Обновление связей и экрана-----------------------------------------
With Application
lCalc = .Calculation
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc: .DisplayAlerts = True: .AskToUpdateLinks = True
.PrintCommunication = True: '.ActivePrinter = "*Brother*DCP-L5500DN*series*" '.Dialogs (xlDialogPrinterSetup)
End With
End Sub
[/vba]

Автор - Elhust
Дата добавления - 26.04.2017 в 09:40
Elhust Дата: Среда, 26.04.2017, 09:41 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 158
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
мне получается друг за другом эти диапазоны вставлять надо
так то банальная задача я и тут почитал http://www.excel-vba.ru/chto-um....-iz-vba
очень хорошая статья про диапазоны и работы с ним но блиин почему то я не нашел


Каждый сам выбирает правила игры

Сообщение отредактировал Elhust - Среда, 26.04.2017, 09:55
 
Ответить
Сообщениемне получается друг за другом эти диапазоны вставлять надо
так то банальная задача я и тут почитал http://www.excel-vba.ru/chto-um....-iz-vba
очень хорошая статья про диапазоны и работы с ним но блиин почему то я не нашел

Автор - Elhust
Дата добавления - 26.04.2017 в 09:41
Elhust Дата: Среда, 26.04.2017, 12:15 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 158
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код

Sub обединить()
Dim iPath$, iFail$, aFail$, ps&
Dim otkuda As Range
Dim kuda As Range
Application.ScreenUpdating = False: Application.EnableEvents = False: Application.DisplayAlerts = False
iPath = "C:\Отчеты\" ' Папка где лежат файлы УКАЗАТЬ СВОЮ
iFail = Dir(iPath)
aFail = ActiveWorkbook.Name
Do While iFail <> ""
    Workbooks.Open Filename:=iPath & iFail
    ps = Range("A" & Rows.Count).End(xlUp).Row
    Set otkuda = Sheets("Лист1").Range("A2:Q" & ps)
    Windows(aFail).Activate
    ps = Range("A" & Rows.Count).End(xlUp).Row + 1
    Set kuda = Sheets("Лист1").Range("A" & ps)
    otkuda.Copy kuda
    Windows(iFail).Close
    iFail = Dir
Loop
Application.ScreenUpdating = True: Application.EnableEvents = True: Application.DisplayAlerts = True
End Sub
[/vba]

нет странно вставил это для проверки и нет не работает


Каждый сам выбирает правила игры

Сообщение отредактировал Elhust - Среда, 26.04.2017, 12:26
 
Ответить
Сообщение[vba]
Код

Sub обединить()
Dim iPath$, iFail$, aFail$, ps&
Dim otkuda As Range
Dim kuda As Range
Application.ScreenUpdating = False: Application.EnableEvents = False: Application.DisplayAlerts = False
iPath = "C:\Отчеты\" ' Папка где лежат файлы УКАЗАТЬ СВОЮ
iFail = Dir(iPath)
aFail = ActiveWorkbook.Name
Do While iFail <> ""
    Workbooks.Open Filename:=iPath & iFail
    ps = Range("A" & Rows.Count).End(xlUp).Row
    Set otkuda = Sheets("Лист1").Range("A2:Q" & ps)
    Windows(aFail).Activate
    ps = Range("A" & Rows.Count).End(xlUp).Row + 1
    Set kuda = Sheets("Лист1").Range("A" & ps)
    otkuda.Copy kuda
    Windows(iFail).Close
    iFail = Dir
Loop
Application.ScreenUpdating = True: Application.EnableEvents = True: Application.DisplayAlerts = True
End Sub
[/vba]

нет странно вставил это для проверки и нет не работает

Автор - Elhust
Дата добавления - 26.04.2017 в 12:15
Elhust Дата: Среда, 26.04.2017, 12:27 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 158
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
:'(


Каждый сам выбирает правила игры
 
Ответить
Сообщение:'(

Автор - Elhust
Дата добавления - 26.04.2017 в 12:27
Elhust Дата: Среда, 26.04.2017, 14:01 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 158
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
сделал по своему но кастыльно получилось не диапазонам а по клеточкам
думаю код никому не интересен....


Каждый сам выбирает правила игры
 
Ответить
Сообщениесделал по своему но кастыльно получилось не диапазонам а по клеточкам
думаю код никому не интересен....

Автор - Elhust
Дата добавления - 26.04.2017 в 14:01
Kuzmich Дата: Среда, 26.04.2017, 16:48 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 326
Репутация: 62 ±
Замечаний: 0% ±

Excel 2003
[vba]
Код
iPath = "C:\Отчеты\" ' Папка где лежат файлы УКАЗАТЬ СВОЮ
[/vba]
А файлы в ней
[vba]
Код
iFail = Dir(iPath & "*.xls")
[/vba]
 
Ответить
Сообщение[vba]
Код
iPath = "C:\Отчеты\" ' Папка где лежат файлы УКАЗАТЬ СВОЮ
[/vba]
А файлы в ней
[vba]
Код
iFail = Dir(iPath & "*.xls")
[/vba]

Автор - Kuzmich
Дата добавления - 26.04.2017 в 16:48
KStarshin Дата: Четверг, 14.09.2017, 09:12 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Доброе утро. У меня есть макрос, который собираем данные с определенных листов. Как мне скорректировать макрос, чтобы данные собирались как значение (сейчас он мне собирает формулы)
[vba][code][/code][/vba]
Sub сбор()
Dim v
Sheets("ALL").Range("a2:q65000").ClearContents

For Each v In Array("Лист1", "Лист2", "Лист3", "Лист4")
With Sheets(v)

With .Range("A21", .Cells(Rows.Count, 1).End(xlUp))
Union(.Columns(1), .Resize(, 16)).Copy Sheets("ALL").Cells(Rows.Count, 1).End(xlUp)(2, 1)

End With
End With
Next

End Sub
 
Ответить
СообщениеДоброе утро. У меня есть макрос, который собираем данные с определенных листов. Как мне скорректировать макрос, чтобы данные собирались как значение (сейчас он мне собирает формулы)
[vba][code][/code][/vba]
Sub сбор()
Dim v
Sheets("ALL").Range("a2:q65000").ClearContents

For Each v In Array("Лист1", "Лист2", "Лист3", "Лист4")
With Sheets(v)

With .Range("A21", .Cells(Rows.Count, 1).End(xlUp))
Union(.Columns(1), .Resize(, 16)).Copy Sheets("ALL").Cells(Rows.Count, 1).End(xlUp)(2, 1)

End With
End With
Next

End Sub

Автор - KStarshin
Дата добавления - 14.09.2017 в 09:12
_Boroda_ Дата: Четверг, 14.09.2017, 09:17 | Сообщение № 8
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11852
Репутация: 4911 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Прочитайте Правила форума и создайте свою тему.
Прекрасно, что Вы воспользовались кнопкой тегов для макросов, обычно сначала приходится долго принуждать к этому. А чтобы все совсем правильно было, немного поясню - сам код макроса нужно вставлять в середину тегов, между code
['vba]['code]Вот здесь['/code]['/vba]
Можно вставить код макроса, выделить его и нажать кнопку #


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПрочитайте Правила форума и создайте свою тему.
Прекрасно, что Вы воспользовались кнопкой тегов для макросов, обычно сначала приходится долго принуждать к этому. А чтобы все совсем правильно было, немного поясню - сам код макроса нужно вставлять в середину тегов, между code
['vba]['code]Вот здесь['/code]['/vba]
Можно вставить код макроса, выделить его и нажать кнопку #

Автор - _Boroda_
Дата добавления - 14.09.2017 в 09:17
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование диапазона (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!