1 Тема от GFeniks (изменено: GFeniks, 2023-11-07 09:19:09)

  • GFeniks
  • Участник
  • Неактивен

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

Добрый день.
Использую 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

Прикрепляю архив примера (данные левые, нужен чисто принцип), плиз хелп

Post's attachments

Primer dlya foruma_02.11.2023.zip 34.99 kb, 1 downloads since 2023-11-07 

You don't have the permssions to download the attachments of this post.

2 Ответ от andypetr

  • andypetr
  • Разработчик
  • Неактивен

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

GFeniks, добрый день.

Вот, что-то вроде работающее:

Sub cbMakeIskluchSpsok_Click()
 
    ' ошибки обрабатываем сами.
    On Error Resume Next
    
    'Переменные для хранения имен файлов старого и нового списков
    Dim old_sp_book As String
    Dim new_sp_book As String
    Dim iskl_sp_book As String
    'Переменная для хранения имени файла списка исключенных
    Dim old_spisok As Workbook
    Dim new_spisok As Workbook
    Dim iskl_spisok As Workbook
    'Рабочие листы в файлах (все первые)
    Dim old_sheet As Worksheet
    Dim new_sheet As Worksheet
    Dim iskl_sheet As Worksheet
    
    'Устанавливаем активным каталог книги, из которой запущен макрос
    ChDir ThisWorkbook.Path
    
    'Признак ошибки
    Dim bError As Boolean
    
    'Открываем файл старого списка
    Set old_spisok = Open_Xls("old_sp")
    'Открываем файл нового списка
    Set new_spisok = Open_Xls("new_sp")
    
    bError = (old_spisok Is Nothing) Or (new_spisok Is Nothing)
    
    If Not bError Then
        
        iskl_sp_book = ThisWorkbook.Path & "\" & "Iskl_spisok_Added " & CStr(Date) & ".xls"
        'Создаем ексель-книгу для списка исключенных
        Set iskl_spisok = Workbooks.Add
        'Сохраняем созданную эксель-книгу со списка исключенных
        iskl_spisok.SaveAs Filename:=iskl_sp_book, FileFormat:=xlExcel8, _
            Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
            CreateBackup:=False
        
        Set old_sheet = old_spisok.Sheets(1)
        Set new_sheet = new_spisok.Sheets(1)
        Set iskl_sheet = iskl_spisok.Sheets(1)
        
        'Последняя строка с данными
        Dim new_sheet_end_row As Long, CurrNumericRow As Long
        new_sheet_end_row = new_sheet.Cells.SpecialCells(xlLastCell).Row
        
        'Переменная-счетчик для перебора строк нового списка
        Dim i_new As Long, i_iskl As Long
        
        For i_new = 1 To new_sheet_end_row
            CurrNumericRow = Val(new_sheet.Cells(i_new, 1).Value)
            If CurrNumericRow > 0 Then
                ' текущая строка в исключениях
                i_iskl = i_iskl + 1
                old_sheet.Rows(CurrNumericRow).Copy iskl_sheet.Rows(i_iskl)
            Else
                'ничего не делать :)))
            End If
        Next i_new
            
    End If 'Not bError
    
    'Закрываем файлы
    Close_Xls iskl_spisok, True 'сохранить изменения
    Close_Xls old_spisok, False 'не сохранять изменения
    Close_Xls new_spisok, False 'не сохранять изменения
 
    Set old_spisok = Nothing
    Set new_spisok = Nothing
    Set iskl_spisok = Nothing
 
End Sub

' Открывает рабочую книгу с перебором расширений.
' Возвращает объект Workbook или Nothing в случае ошибки.
Function Open_Xls(ByVal sFileName As String) As Workbook
    Dim sExt, sFile As String
    Set Open_Xls = Nothing
    
    For Each sExt In Array(".xls", ".xlsx")
        sFile = ActiveWorkbook.Path + "\" + sFileName + sExt
        If Dir(sFile) <> "" Then
            Set Open_Xls = Workbooks.Open(sFile)
            Exit For
        End If
    Next sExt

    If Open_Xls Is Nothing Then
        MsgBox "Ошибка открытия: " & sFileName
    End If

End Function

' Закрывает рабочую книгу.
Sub Close_Xls(ByVal oWorkbook As Workbook, Optional ByVal bSaveChanges As Boolean)
    If Not oWorkbook Is Nothing Then
        oWorkbook.Close bSaveChanges 'True = сохранять изменения
    End If
End Sub

Пояснения:

  • Application.CutCopyMode - нет смысла устанавливать. Также, как и пользоваться Activate/Select/Copy/Paste.

  • Перебор расширений (".xls", ".xlsx") я спрятал в функцию: Open_Xls.

  • В основном цикле (For i_new = 1 To new_sheet_end_row) перебираются все строки листа new_sheet и в случае ненулевого значения в первом столбце строка с таким номером (CurrNumericRow) копируется из old_sheet в iskl_sheet (в очередную строку i_iskl).

  • Выражение sheet.Rows(N) обращается к строке N целиком (можно не выделять часть строки с помощью громоздкого Range).

  • Количество строк для цикла - это номер строки последней заполненной ячейки листа new_sheet: Cells.SpecialCells(xlLastCell). На данную ячейку мы попадаем по нажатию Ctrl-End.