Отправляет email-рассылки с помощью сервиса Sendsay

RFpro.ru: Программирование на Basic / VBA

Подписаться Бесплатная «Золотая» новостная рассылка . Подписчиков 1.824 RSS
←   Октябрь 2009   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31


За последние 60 дней ни разу не выходила


Сайт рассылки: http://prog.rusfaq.ru/basic
Открыта: 14-03-2002

Автор
Калашников О.А.

Статистика

1.824 подписчиков
0 за неделю
←   Все выпуски   →

RFpro.ru: Программирование на Basic / VBA


Хостинг портала RFpro.ru:
Московский хостер
Профессиональный платный хостинг на базе Windows 2008

РАССЫЛКИ ПОРТАЛА RFPRO.RU

Чемпионы рейтинга экспертов в этой рассылке

Гуревич Александр Львович
Статус: 10-й класс
Рейтинг: 1264
∙ повысить рейтинг » 		Megaloman
Статус: Бакалавр
Рейтинг: 674
∙ повысить рейтинг » 		Botsman
Статус: Специалист
Рейтинг: 512
∙ повысить рейтинг »

/ КОМПЬЮТЕРЫ И ПО / Программирование / Basic/VBA

Номер выпуска:938
Дата выхода:20.10.2009, 12:30
Администратор рассылки:Калашников О.А., Руководитель
Подписчиков / экспертов:362 / 95
Вопросов / ответов:1 / 2

Вопрос № 173297: Здравствуйте уважаемые эксперты! В одной папке находится данные установленного образца в формате *.xls. Имеется файл свод.xls в котором необходимо организовать по нажатию кнопки перенос информации. То есть копировать информацию. Но копировать необход...

Вопрос № 173297:

Здравствуйте уважаемые эксперты! В одной папке находится данные установленного образца в формате *.xls. Имеется файл свод.xls в котором необходимо организовать по нажатию кнопки перенос информации. То есть копировать информацию. Но копировать необходимо не все строки. Начинать копирование необходимо во всех файлах с восьмой строки, а вот количество строк в разных файлах меняется. Вариант поиска окончания следующий: определить первую пустую после восьмой и вывести все строки за исключением последней (например, пустая строка 13 – значит необходимо вывести строки с 8 по 12). Т.е. если допустим в 1 файле таких строк 5, во втором 10 и т.д. то из первого берутся 5 строк и помещаются в сводный, далее с 6 строки из второго 10 и т.д. Количество исходных файлов может меняться, т.е. не постоянно. И еще всю строку забирать нет необходимости достаточно взять только с A до S ячейки в строке.

Отправлен: 15.10.2009, 12:05
Вопрос задал: vitekvot, Посетитель
Всего ответов: 2
Страница вопроса »

Отвечает HookEst, Специалист :
Здравствуйте, vitekvot.
например так:
Код:

Option Explicit

Const XL_FOLDER = "C:\dev\xl\" 'папка где лежат файлы с данными

Sub t()
Dim src As Range
Dim dst As Range
Dim wb As Workbook
Dim file As String
    Set dst = ThisWorkbook.Worksheets(1).Range("A1")
'куда начинаем копировать
    file = Dir(XL_FOLDER & "*.xls")
    While file <> ""
        Set wb = Workbooks.Add(XL_FOLDER & file)
        Set src = wb.Worksheets(1).Range("A8:S8")
        While Not IsEmpty(src(1)) 'подразумевал, что если первая ячейка пустая, то и вся строка пустая, если это не так, условие надо поменять..
            src.Copy dst
            Set src = src.Off
 set(1)
            Set dst = dst.Offset(1)
        Wend
        wb.Close
        file = Dir
    Wend
End Sub

Успехов...

Ответ отправил: HookEst, Специалист
Ответ отправлен: 15.10.2009, 16:06

Оценка ответа: 4
Комментарий к оценке:
Спасибо. 4 потомо что по условию задачи забирать нужно не все строки до пустой, а все кроме последней.

Как сказать этому эксперту "спасибо"?
  • Отправить SMS #thank 255444 на номер 1151 (Россия) | Еще номера »
  • Отправить WebMoney:
    • Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    Отвечает Megaloman, Бакалавр :
    Здравствуйте, vitekvot.
    Вот макрос, который решает Вашу задачу.
    В начале кода настройте пути и координаты данных
    Файлы с примером (в упвкованном виде) прикрепил к ответу - скачайте и смотрите. Как организовать кнопку - смотрите минифорум Вопрос № 172966

    Код:
    Sub Svod()
    '
Исходные данные  ----------------------------------------------------------------------
        RabDir = "H:\Delete\Откуда грузим"      ' Где данные для загрузки
        Maska = "*.xls"                         ' Маска имени загружаемых файлов
        
        FromBegRange = "A8:S8"                  ' Диапазон первой строки закружаемых данных
        
        BegRange = "B8"                         ' Адрес левой верхней 
 клетки в своде
    ' ---------------------------------------------------------------------------------------
        
        SvodFileName = ActiveWorkbook.Name          ' Наименование файла со сводом
        ListSvod = ActiveWorkbook.ActiveSheet.Name  ' Имя листа со сводом
        
        nCol = Range(FromBegRange).Count            ' Число загружаемых клеток в строке
        
        FromC = Range(FromBegRange).Column          ' Номер колонки начала забираемого диапазона
        FromR = Range(FromBegRange).Row
            ' Номер строки начала забираемого диапазона
        
        InC = Range(BegRange).Column                ' Номер колонки начала диапазона в своде
        InR = Range(BegRange).Row                   ' Номер строки начала диапазона в своде
        
            
        ChDir RabDir
        
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set Tdir = FSO.GetFolder(RabDir)
        Set AllFiles = Tdir.Files
        
        Dim Mass As Variant
            
        Sheets(ListSvod).Select
        Columns("A:Z").ClearContents             ' Очищаю лист куда буду грузить
        Range("A1").Select
        
        BegRow = InR

        For Each iFile In AllFiles
            jName = iFile.Name
            
            If jName Like Maska Then
                Cells(BegRow, InC - 1) = jName         ' Отладочная печать имён файлов в директории
                On Error Resume Next
                    Workbooks.Open
Filename:=RabDir + "\" + jName    ' Открываем Exel файл
            
                    If Err.Number = 0 Then
                        On Error GoTo 0
                        
                        n = 0
                        Do While Trim(Cells(FromR + n, FromC)) <> ""
                            n = n + 1
                        Loop
                        
                        If n <> 0 Then
                            Mass = Range(C
 ells(FromR, FromC), Cells(FromR + n - 1, FromC + nCol - 1))
                            Windows(SvodFileName).Activate
                            Range(Cells(BegRow, InC), Cells(BegRow + n - 1, InC + nCol - 1)).Value = Mass
                            BegRow = BegRow + n
                        End If
                        Windows(SvodFileName).Activate
                        
                        Workbooks(jName).Close SaveChanges:=False   ' Закрываем книгу из которой брали данные
                    End
If

            End If
        Next


    End Sub

    Прикрепленный файл: загрузить »

    -----
    Нет времени на медленные танцы

    Ответ отправил: Megaloman, Бакалавр
    Ответ отправлен: 15.10.2009, 16:37

    Оценка ответа: 4
    Комментарий к оценке:
    Спасибо. Ваш вариант безусловно предпочтительнее, 4 потомо что по условию задачи забирать нужно не все строки до пустой, а все кроме последней.

    Как сказать этому эксперту "спасибо"?
  • Отправить SMS #thank 255446 на номер 1151 (Россия) | Еще номера »
  • Отправить WebMoney:
    • Вам помогли? Пожалуйста, поблагодарите эксперта за это!

    Оценить выпуск »
    Нам очень важно Ваше мнение об этом выпуске рассылки!

    Задать вопрос экспертам этой рассылки »

    Скажите "спасибо" эксперту, который помог Вам!

    Отправьте СМС-сообщение с тестом #thank НОМЕР_ОТВЕТА
    на короткий номер 1151 (Россия)
    Номер ответа и конкретный текст СМС указан внизу каждого ответа.

    Полный список номеров »

    * Стоимость одного СМС-сообщения от 7.15 руб. и зависит от оператора сотовой связи. (полный список тарифов)
    ** При ошибочном вводе номера ответа или текста #thank услуга считается оказанной, денежные средства не возвращаются.
    *** Сумма выплаты эксперту-автору ответа расчитывается из суммы перечислений на портал от биллинговой компании.

    © 2001-2009, Портал RFpro.ru, Россия
    Авторское право: ООО "Мастер-Эксперт Про"
    Автор: Калашников О.А. | Программирование: Гладенюк А.Г.
    Хостинг: Компания "Московский хостер"
    Версия системы: 2009.6.9 от 25.09.2009
    В избранное