Две книги с данными, перенести нужные из 2-ух в 3-тью

Программирование на Visual Basic for Applications
GFeniks
Начинающий
Начинающий
 
Сообщения: 1
Зарегистрирован: 07.11.2023 (Вт) 8:21

Две книги с данными, перенести нужные из 2-ух в 3-тью

Сообщение GFeniks » 07.11.2023 (Вт) 8:25

Добрый день.
Использую MS Excel 2010.
Сразу говорю: программист я начинающий.
Есть книга, из которой запускается макрос VBA, она открывает файл "old_sp.xls" (таблица со старыми данными граждан: Фамилия, Имя и тд., заголовков таблицы нет, идут сразу строки с данными) и файл "new_sp.xls" (с новыми данными граждан: Номер гражданина в выборке, Фамилия, Имя и тд., заголовки таблицы есть), также макрос создает новую книгу. В файле "new_sp.xls" строки с данными идут не подряд, а имеются пустые строки. Нужно найти в файле "new_sp.xls" непустую строку, проверить, что в ее первой ячейке слева стоит именно чиcло (это номер гражданина в выборке, колонка называется "№, п/п"), запомнить этот номер в переменной, и в старом списке, "old_sp.xls", отсчитать сверху количество строк, равное числу в сохранённой переменной, если эта строка не пуста, то скопировать всю строку с данными по текущему гражданину в созданный xls-файл. И так нужно перебрать все строки в файле "new_sp.xls". Затем когда вновь созданная книга (список исключённых граждан) будет заполнена, строками из "old_sp.xls", сохранить ее на жёсткий диск.

Я пошёл через циклы While Do...Loop. Пока у меня обрабатывается только первая непустая строка, с номером, из нового списка. Как сделать, чтобы обрабатывались все строки из нового списка и соответствующие им строки из старого списка копировались в список исключенных?

Код:

Код: Выделить всё
Sub cbMakeIskluchSpsok_Click()

    'Переменные для хранения имен файлов старого и нового списков
    Dim old_sp_book As String
    Dim new_sp_book As String
    'Переменная для хранения имени файла списка исключенных
    Dim old_spisok As Workbook
    Dim new_spisok As Workbook
    Dim iskl_spisok As Workbook
   
    'Устанавливаем активным каталог книги, из которой запущен макрос
    ChDir (ThisWorkbook.Path)
    'Устанавливаем режим копирования-вставки
    Application.CutCopyMode = True
   
    'Открываем файл старого списка
    If Dir(ActiveWorkbook.Path + "\" + "old_sp.xls") = "" Then
   
        Workbooks.Open ActiveWorkbook.Path + "\" + "old_sp.xlsx"
        Set old_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "old_sp.xlsx")
   
    Else
   
        Workbooks.Open ActiveWorkbook.Path + "\" + "old_sp.xls"
        Set old_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "old_sp.xls")

    End If

    'Открываем файл нового списка
    If Dir(ThisWorkbook.Path + "\" + "new_sp.xls") = "" Then
   
        Workbooks.Open ActiveWorkbook.Path + "\" + "new_sp.xlsx"
        Set new_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "new_sp.xlsx")
   
    Else
   
        Workbooks.Open ActiveWorkbook.Path + "\" + "new_sp.xls"
        Set new_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "new_sp.xls")
   
    End If

    'Создаем ексель-книгу для списка исключенных
    Set iskl_spisok = Workbooks.Add
   
    'Сохраняем и закрываем созданную эксель-книгу со списка исключенных
    iskl_spisok.SaveAs Filename:=ThisWorkbook.Path & "\" & "Iskl_spisok_Added " & CStr(Date) & ".xls",

FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
   
   
    'Переменные-счестчики для перебра строк нового старого списка, старого списка и списка сиключенных
    'Переменная-счетчик для перебора строк нового списка
    Dim i As Long
    'Переменная-счетчик для перебора строк старого списка
    'Dim j As Long
    'Переменная-счетчик для перебора строк списка исключенных
    Dim k As Long
    'Переменная для хранения номера непстой строки в новом списке
    Dim CurrNumericRow As Long
    'Метка для продолжения цикла с перебором строк в новом списке
    Dim Metka As Label
   
    '''Действия по формированию списка исключенных граждан
    'Активация файла нового списка
    i = 1
    k = 1
   
Metka:
   
    new_spisok.Activate
   
    ActiveWorkbook.Sheets(1).Activate
   
    Do While i <> 65535
   
   
        If ActiveSheet.Range(Cells(i, 1).Address).Text <> "" And IsNumeric(ActiveSheet.Range(Cells(i,

1).Address).Text) = True Then
       
                        CurrNumericRow = CLng(ActiveSheet.Range(Cells(i, 1).Address).Text)
                       
                        old_spisok.Activate
                       
                        ActiveWorkbook.Sheets(1).Activate
           
                        ActiveSheet.Range(Cells(CurrNumericRow, 1).Address & ":" & Cells(CurrNumericRow,

11).Address).Select
                               
                        Selection.Copy
                       
                       'Вставка ранее скопированного дисапозона ячеек в список исключенных граждан
                        iskl_spisok.Activate
                           
                        ActiveWorkbook.Sheets(1).Activate
                       
                       
                        Do While k <> 65535
                       
                            If ActiveSheet.Range(Cells(k, 1).Address).Text = "" Then
                               
                                ActiveSheet.Range(Cells(k, 1).Address).Select
                               
                                ActiveSheet.Paste
                               
                                Exit Do
                           
                            Else
                                   
                                k = k + 1
                           
                            End If
       
       
                        Loop

            Else
                       
                    'ничего не делать :)))
                   
            End If
           
           i = i + 1
           
     Loop
       
    'Сохранение сформированного файла-списка исключенных
    'iskl_sp_book.SaveAs "????_?_?????\Я идиот! Убейте меня, кто-нибудь!?_?Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!.xls"

End Sub


Прикрепляю архив примера (данные левые, нужен чисто принцип), плиз хелп :)
Вложения
Primer dlya foruma_02.11.2023.zip
(34.99 Кб) Скачиваний: 37

Вернуться в VBA

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1

    TopList