Страницы: 1
RSS
Заполнить столбец листа данными с другого листа по условию
 
Добрый день всем !

В таблице два листа.
Первый лист "База_данных" - в ней 3 столбца "Ед.измерения","Год оценки","Курс валюты"
Второй лист "Курсы" - в нем внесены данные в ячейки по году оценки и еденице измерения
Как макросом перенести данные (курсы валют)в столбец U4:U первого листа "База_данных" из второго листа "Курсы" (исходя из совпадающих значений едениц измерения и год оценки на 1 листе со 2 листом) ?

Файл с примером приложил.
 
Добрый день

Прописал формулу, если пригодится
Макросом, нужно по годам и валютам бежать циклом или поиском, и находить координаты нужных данных
 
Спасибо за поддержку - но нужно с  макросом решение   :(  
Изменено: serg555 - 01.08.2021 16:52:49
 
Попробовал сам сделать на примере - но ввиду моих скудных знаний ничего не получилось
Код
Sub КурсВалюты()
Dim j%, n%, c%, b%, Row1, Column1, Row2, Column2
Dim Sh2 As Worksheet, Sh1 As Worksheet
Set Sh1 = Sheets("База_данных")
Set Sh2 = Sheets("Курсы")

For j = 1 To Sh1.Cells(Rows.Count, 1).End(xlUp).Row
    For n = 1 To Sh2.Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(j, 15) = Sh2.Cells(n, 1) Then
           Row1 = Sh1.Cells(j, 15).Row
           Row2 = Sh2.Cells(n, 1).Row
             For c = 1 To Sh1.Cells(Rows.Count, 1).End(xlUp).Row
             For b = 1 To Sh2.Cells(1, Columns.Count).End(xlToLeft).Column
                 If Cells(c, 19) = Sh2.Cells(1, b) Then
                   Column2 = Sh2.Cells(1, b).Column
                   
                   Sh1.Cells(Row1, 21) = Sh1.Cells(Row2, Column2)
                   
                 End If
             Next
             Next
        End If
             
    Next
Next
 
 
End Sub

Может кто поправить ?
 
Цитата
нужно с  макросом решение
Посмотрите вариант
Код
Sub КурсВалюты()
Dim i As Long
Dim iLastRow As Long
Dim cell As Range
Dim Kurs As Worksheet
Dim FoundYear As Integer
  Set Kurs = ThisWorkbook.Worksheets("Курсы")
  iLastRow = Cells(Rows.Count, "O").End(xlUp).Row
With Kurs
 Range("U4:U" & iLastRow).ClearContents
    For i = 4 To iLastRow
        Set cell = .Columns(1).Find(WorksheetFunction.Trim(Cells(i, "O")), , xlValues, xlPart)
        If Not cell Is Nothing Then
          FoundYear = .Rows(1).Find(Cells(i, "S"), , xlValues, xlWhole).Column
          If Not IsEmpty(FoundYear) Then
            Cells(i, "U") = .Cells(cell.Row, FoundYear)
          End If
        End If
    Next
End With
End Sub
 
Благодарю Kuzmich ! Вроде работает как надо - только сверить значения надо вручную что получается. Завтра отпишусь
P.S. Проверил - все корректно заполняет - еще раз благодарю за помощь !
Изменено: serg555 - 03.08.2021 12:47:09
Страницы: 1
Наверх