Страницы: 1
RSS
VBA - получение значений из файлов по цвету ячейки, получение макросом значений ячеек из файлов по цвету заливки ячейки
 
Коллеги, помогите пожалуйста разобраться ..
Пишу макрос, который
1) открывает файлы excel через диалоговое окно
2) вставляет название этих файлов в столбец 1 на лист 1 рабочей книги,
3) при условии, если ячейки в этих файлах залиты определенным цветом, значение этих ячеек последовательно вставляет на лист 1 рабочей книги в разные столбцы (2,3,4)
4) закрывает открытые файлы

Всего у меня в есть ячейки закрашенные тремя цветами .
Код работает нормально для двух цветов 65535 и 15921906 , при попытке добавить цикл  по третьему цвету 16247773 код начинает работать некорректно
- не закрывает открытые файлы и вставляет в столбец 4 значение ячеек с цветом 16247773,
при проверки кода построчно значение переменной r = emty ..

Код макроса всего привожу ниже,  часть кода, который я добавляю для цвета 16247773 выделил красным , если его убрать все работает нормально..
Не могу понять в чем ошибка .. полагаю что то не так с циклом For


Sub CombineanWBrenameSH1()
   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 c = Workbooks.Open(Filename:=FilesToOpen(x))
          wbname = c.Name
           ThisWorkbook.Sheets("Лист1").Cells(x + 1, 1).Value = wbname
       For Each cell In Range("A1:N5000")
          If cell.Interior.Color = 65535 Then
            v = cell.Value
              ThisWorkbook.Sheets("Лист1").Cells(x + 1, 3).Value = v
       Exit For
       End If
       Next
         For Each cell In Range("A1:N5000")
           If cell.Interior.Color = 15921906 Then
             n = cell.Value
               ThisWorkbook.Sheets("Лист1").Cells(x + 1, 2).Value = n
      Exit For
       End If
       Next
         For Each cell In Range("A1:N5000")
          If cell.Interior.Color = 16247773 Then
           r = cell.Value
            ThisWorkbook.Sheets("Лист1").Cells(x + 1, 4).Value = r
              c.Close savechanges:=False
       
       
       End If
       Next
       x = x + 1
       
   Wend

   Application.ScreenUpdating = True
 
Код
Sub CombineanWBrenameSH1()
  Dim FilesToOpen, x As Integer, r&, cr, c
  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:  r = 1:  cr = Array(0, 0, 15921906, 65535, 16247773)
  While x <= UBound(FilesToOpen)
    Set c = Workbooks.Open(Filename:=FilesToOpen(x))
    With ThisWorkbook.Sheets("Лист1")
      For Each cell In Range("A1:N5000")
        For i = 2 To 4
          If cell.Interior.Color = cr(i) Then
            r = r + 1: .Cells(r, 1) = c.Name: .Cells(r, i) = cell: Exit For
          End If
        Next
      Next
    End With
    c.Close False: x = x + 1
  Wend
  Application.ScreenUpdating = true
End Sub
Изменено: Ігор Гончаренко - 27.09.2022 16:54:38
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Close после Next как минимум должен быть
Скажи мне, кудесник, любимец ба’гов...
 
Цитата
написал:
Close после Next как минимум должен быть
Да, спасибо !  сейчас открытые файлы закрываются.. но почему у переменной r нет значения не понимаю ..  ячейки закрашенные 16247773 есть , а значений у переменной нет..  
 
Цитата
написал:
Код
    [URL=#]?[/URL]       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      Sub   CombineanWBrenameSH1()        Dim   FilesToOpen, x   As   Integer  , r&, cr, c        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: cr = Array(0, 0, 15921906, 65535, 16247773)        While   x <= UBound(FilesToOpen)          Set   c = Workbooks.Open(Filename:=FilesToOpen(x))          With   ThisWorkbook.Sheets(  "Лист1"  )            For   Each   cell   In   Range(  "A1:N5000"  )              For   i = 2   To   4                If   cell.Interior.Color = cr(i)   Then                  r = r + 1: .Cells(r, 1) = c.Name: .Cells(r, i) = cell:   Exit   For                End   If              Next            Next          End   With          c.Close   False  : x = x + 1        Wend        Application.ScreenUpdating = true    End   Sub   
 
Спасибо !, но ваш код работает некорректно - данные располагаются на листе в разнобой , последовательность не соблюдается.  

Вот пример работы моего кода - для примера указал в шапке столбцов наименование переменных из кода.
Проблема с наименованием регистра - в моем коде это переменная r .  В  открываемых файлах эти ячейки закрашены 16247773, но значения переменной не присваиваются

Наименование   файла ( wbname )Налогоплательщик   ( n )сумма по   регистру ( v )Наименование регистра ( r )
ТП_Рязань_010_2_02   (XLSX).xlsxНалогоплательщик:  ООО   "Рога и копыта"3 464 670 551,41
ТП_Рязань_010_2_02.01   (XLSX).xlsxНалогоплательщик:  ООО   "Рога и копыта"8 545 248,26
ТП_Рязань_010_2_02_ПФ   (XLSX).xlsxНалогоплательщик:  ООО   "Рога и копыта"100 000,00
ТП_Рязань_011_1_02 (XLSX).xlsxНалогоплательщик:  ООО   "Рога и копыта"3 986 598 413,45
 
Цитата
Nik1980 написал:
В  открываемых файлах эти ячейки закрашены 16247773
Значит нет. Чем докажите?
 
хорошо, а в результате работы моего варианта  данные из одного файла попадают в разные строки, но в свои хоть колонки и все данные собраны?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
написал:
Цитата
Nik1980 написал:
В  открываемых файлах эти ячейки закрашены 16247773
Значит нет. Чем докажите?
Может пример прислать .. ?  
 
Цитата
Nik1980 написал:
Может пример прислать .. ?  
Какой интересный вопрос.  :D
 
Цитата
написал:
Цитата
Nik1980 написал:
Может пример прислать .. ?  
Какой интересный вопрос.  
Вот пример
Файл Регистры - это файл сбора информации (Нужный макрос в модуле 3 - активируется при нажатии кнопки Заполнить данные из регистров
после запуска макроса выбираем два файла Рога и Копыта . из них на лист 1 в столбцы 1-4 файла Регистры должны подтянуться необходимые данные, закрашенные 65535, 15921906, 15853276 .  Данные закрашенные 15853276 .не подтягиваются. Цвет верный поскольку если например этот цвет поменять местами с другими то данные подтягиваются
 
 
Цитата
написал:
рограммисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, ко
Добрый день. Нет данные подтягиваются некорректно . Примеры подгрузил выше - ваш макрос в модуле 2  (файл Регистры)
 
Если в ячейку поверх значения записать Empty, то в ячейке и будет Empty.
А вы это проделываете трижды.
 
открывайте регистры
запускайте макрос
выберите файл 3Color
что не так в результатах?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
написал:
Если в ячейку поверх значения записать Empty, то в ячейке и будет Empty.
А вы это проделываете трижды.
Спасибо! .. я понял )  добавил  выход   Exit For
теперь все работает

For Each cell In Range("A1:N5000")
       If cell.Interior.Color = 15853276 Then
       r = cell.Value
       ThisWorkbook.Sheets("Лист1").Cells(x + 1, 4).Value = r
       Exit For
 
Цитата
написал:
открывайте регистры
запускайте макрос
выберите файл 3Color
что не так в результатах?
Вот пример работы вашего макроса с файлом 3Color .
Вы когда цикл писали ориентировались на ситуацию, при которой будет один файл и много закрашенных ячеек .
Но у меня будет 1000 файлов и в каждом файле будет только 3 закрашенных ячейки  (три цвета - три ячейки)

Вот результат работы моего макроса.
Наименование   файла ( wbname )Налогоплательщик   ( n )сумма по   регистру ( v )Наименование регистра ( r )
Рога_и_Копыта_010_2_02   (XLSX).xlsxНалогоплательщик:  ООО   "Рога и Копыта"3 464 670 551,41Регистр учета стоимости МПЗ, списанных в отчетном периоде
Рога_и_Копыта_010_2_02.01   (XLSX).xlsxНалогоплательщик:  ООО   "Рога и Копыта"8 545 248,26Регистр учета прямых расходов на производство

Вот пример работы вашего макроса с моими двумя файлами - цвета сделал соответствующие моим Array(0, 0, 15921906, 65535, 15853276)

Наименование   файла ( wbname )Налогоплательщик   ( n )сумма по   регистру ( v )Наименование регистра ( r )
Рога_и_Копыта_010_2_02   (XLSX).xlsxРегистр учета стоимости МПЗ, списанных в отчетном периоде
Рога_и_Копыта_010_2_02   (XLSX).xlsx
Рога_и_Копыта_010_2_02   (XLSX).xlsx
Рога_и_Копыта_010_2_02   (XLSX).xlsx
Рога_и_Копыта_010_2_02   (XLSX).xlsxНалогоплательщик:  ООО   "Рога и Копыта"
Рога_и_Копыта_010_2_02   (XLSX).xlsx
Рога_и_Копыта_010_2_02   (XLSX).xlsx3 464 670 551,41
Рога_и_Копыта_010_2_02.01   (XLSX).xlsxРегистр учета прямых расходов на производство
Рога_и_Копыта_010_2_02.01   (XLSX).xlsx
Рога_и_Копыта_010_2_02.01   (XLSX).xlsx
Рога_и_Копыта_010_2_02.01   (XLSX).xlsx
Рога_и_Копыта_010_2_02.01   (XLSX).xlsxНалогоплательщик:  ООО   "Рога и Копыта"
Рога_и_Копыта_010_2_02.01   (XLSX).xlsx
Рога_и_Копыта_010_2_02.01   (XLSX).xlsx
Рога_и_Копыта_010_2_02.01   (XLSX).xlsx8 545 248,26
 
Цитата
Nik1980 написал:
Но у меня будет 1000 файлов и в каждом файле будет только 3 закрашенных ячейки
как бы ни так(((
открываю файл Рога.... В1, В3, С3, Д3, Е9 - это сколько закрашеных ячеек по-вашему?

пробуйте этот:
Код
Sub CombineanWBrenameSH2()
  Dim FilesToOpen, x As Integer, r&, cnt, cr
  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: r = 1: cr = Array(0, 0, 15921906, 65535, 15853276)
  While x <= UBound(FilesToOpen)
    Set c = Workbooks.Open(Filename:=FilesToOpen(x)): r = r + 1: cnt = 0
    With ThisWorkbook.Sheets("Лист1")
      For Each cell In ActiveSheet.UsedRange
        For i = 2 To 4
          If cell.Interior.Color = cr(i) And Not IsEmpty(cell) Then
            cnt = cnt + 1: If cnt = 1 Then .Cells(r, 1) = c.Name
            .Cells(r, i) = cell: Exit For
          End If
        Next
        If cnt = 3 Then Exit For
      Next
    End With
    c.Close False: x = x + 1
  Wend
  Application.ScreenUpdating = True
End Sub
Изменено: Ігор Гончаренко - 28.09.2022 13:13:50
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Страницы: 1
Наверх