Страницы: 1
RSS
Консолидация данных из разных щитов в один, VBA цикл модифицировать код
 
Доброго всем дня.
Есть код. появилась необходимость его немного модернизировать (в VBA ничего не понимаю). Вкратце: код консолидирует данные из разных щитов в один согласно названиям колонок в главном щите.
Так как в некоторых листах нет колонок с заданным названием я бы хотел чтобы код проставлял следующий текст "N/R" вместо пробелов (сейчас код так работает)
сам код
Код
Sub SS_WP_UpDateData()
    
    Sheets("Weekly_Plan_Sites").Select
    Range("A2").Select
    
    Dim i As Long, j As Long, k As Long, n As Long, wData As Worksheet, _
        Process(1 To 5) As String, iProc As Long, Dict As Object
    Process(1) = "Sheet1"
    Process(2) = "Sheet2"
    Process(3) = "Sheet3"
    Process(4) = "Sheet4"
    Process(5) = "Sheet5"
    
                        
    Set wData = Sheets("Weekly_Plan_Sites")
    Set Dict = CreateObject("Scripting.Dictionary")
    With wData
        .UsedRange.Offset(1).Clear
        For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            If Len(.Cells(1, j)) > 0 Then Dict.Add LCase$(.Cells(1, j)), j
        Next j
    End With
    i = 2
    For iProc = 1 To 5
        With Sheets(Process(iProc))
            n = .Cells(.Rows.Count, 1).End(xlUp).Row
            For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If Dict.exists(LCase$(.Cells(1, j))) Then
                    k = Dict(LCase$(.Cells(1, j)))
                    .Cells(2, j).Resize(n - 1).Copy wData.Cells(i, k).Resize(n - 1)
                End If
            Next j
        End With
        i = i + n - 1
    Next iProc
End Sub
Изменено: sanych09 - 26.04.2019 14:04:05
Опыт и практика - великое дело! Век живи, Век учись!
 
sanych09, перед 31 строкой вставьте
Код
                Else
                    wData.Cells(i, k).Resize(n - 1) = "N/R"
Файл-пример бы не помешал!
 
Казанский, спасибо! сегодня немогу проверить. завтра проверю и файл образец приложу, если предложенный вариант даст сбой
Опыт и практика - великое дело! Век живи, Век учись!
 
Казанский, добрый день
добавил код... но "N/R" так и не прописывает...:(.  файл приложил для наглядности
Опыт и практика - великое дело! Век живи, Век учись!
 
sanych09, да, уберите это, перед End Sub добавьте
Код
    wData.UsedRange.SpecialCells(xlCellTypeBlanks) = "N/R"
 
Казанский, спасибо огромное!
интересный подход. вначале думал нужно как-то в цикл вставить, а оказалось можно в конце все пустоты заменить.
P.S. я бы в любом случае код не написал

хорошего дня!
Опыт и практика - великое дело! Век живи, Век учись!
 
Я посмотрел результат и увидел что код немного перевыполняет задачу. Проблема в том что он просто заменяет все пустоты текстом "N/R" вместо того чтобы ставить "N/R" только в случае с отсутствуюшей колонкой. Ддля теста можно убрать часть (не все) значение во втором листе и посмотреть результат. Думаю что нужно немного менять догику начального кода хотя как это сделать я не знаю...
 
MasterTofel, кстати да. Я на радостях, что все заработало, не обратил на это внимание... Поэтому и у меня изначально была логика, что нужно как-то цикл видоизменить.
Казанский,  можно ли как-то это сделать?
Опыт и практика - великое дело! Век живи, Век учись!
 
sanych09, пробуйте
Код
Sub SS_WP_UpDateData()
        
    Sheets("Master").Select
    Range("A2").Select
    
    Dim i As Long, j As Long, k, n As Long, wData As Worksheet, _
        Process(1 To 3) As String, iProc As Long
    Process(1) = "Sheet2"
    Process(2) = "Sheet3"
    Process(3) = "Sheet4"
                        
    Set wData = Sheets("Master")
    wData.UsedRange.Offset(1).Clear
    i = 2
    For iProc = 1 To 3
        With Sheets(Process(iProc))
            n = .Cells(.Rows.Count, 1).End(xlUp).Row
            For j = 1 To wData.Cells(1, wData.Columns.Count).End(xlToLeft).Column
                k = Application.Match(wData.Cells(1, j), .Rows(1), 0)
                If IsError(k) Then
                    wData.Cells(i, j).Resize(n - 1) = "N/R"
                Else
                    .Cells(2, k).Resize(n - 1).Copy wData.Cells(i, j).Resize(n - 1)
                End If
            Next j
        End With
        i = i + n - 1
    Next iProc
End Sub
 
Но замените пож.
Цитата
sanych09 написал:
модицировать код
на модифицировать, или медитировать, или музицировать  на худой конец.
По вопросам из тем форума, личку не читаю.
 
БМВ, чего-то не могу найти как изменить Название Темы...
Опыт и практика - великое дело! Век живи, Век учись!
 
Поменял.
 
Казанский, Спасибо огромное! Все работает!
Хорошего дня!
Опыт и практика - великое дело! Век живи, Век учись!
 
Цитата
Юрий М написал:
Поменял.
Юр, добей меня этим Щитом.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
Юр, добей меня этим Щитом.
Согласен, такое название поисковиком вряд ли найдёшь, если в поиск его в лоб не вобьёшь.
Страницы: 1
Наверх