Sub Teast() Range("B1:B21").FormulaR1C1 = _ "=IFERROR(INDEX(Data!R1C2:R30C2,MATCH(TRIM(RC1),Data!R1C1:R30C1,0),1),0)" Range("B1:B21").Copy Range("B1:B21").PasteSpecial Paste:=xlPasteValues End Sub
Sub Teast() Range("B1:B21").FormulaR1C1 = _ "=IFERROR(INDEX(Data!R1C2:R30C2,MATCH(TRIM(RC1),Data!R1C1:R30C1,0),1),0)" Range("B1:B21").Copy Range("B1:B21").PasteSpecial Paste:=xlPasteValues End Sub
китин, спасибо, у меня сейчас как раз так. Но я хочу совсем избавится от вычислений на листе, т.е. совсем не вставлять формулу, и сделать так, чтобы все вычисления производились внутри макроса. Возможно ли такое?
китин, спасибо, у меня сейчас как раз так. Но я хочу совсем избавится от вычислений на листе, т.е. совсем не вставлять формулу, и сделать так, чтобы все вычисления производились внутри макроса. Возможно ли такое?drugojandrew
Sub tttt() Dim x, i&, s$ With Sheets("Data") If .FilterMode Then .ShowAllData x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) .Item(x(i, 1)) = x(i, 2) Next i With Sheets("W") If .FilterMode Then .ShowAllData x = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With For i = 1 To UBound(x) s = Trim(x(i, 1)) If .Exists(s) Then x(i, 1) = .Item(s) Else x(i, 1) = 0 Next i End With
Sheets("W").Range("B1").Resize(UBound(x)).Value = x End Sub
[/vba]
... и немножко с формулами )
[vba]
Код
Sub tttt22() Dim rng As Range, x, i&, s$
With Sheets("Data") Set rng = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row) End With With Sheets("W") If .FilterMode Then .ShowAllData x = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With With WorksheetFunction For i = 1 To UBound(x) x(i, 1) = .VLookup(Trim(x(i, 1)), rng, 2, 0) Next i End With Sheets("W").Range("B1").Resize(UBound(x)).Value = x End Sub
[/vba]
вариант без формул:
[vba]
Код
Sub tttt() Dim x, i&, s$ With Sheets("Data") If .FilterMode Then .ShowAllData x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) .Item(x(i, 1)) = x(i, 2) Next i With Sheets("W") If .FilterMode Then .ShowAllData x = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With For i = 1 To UBound(x) s = Trim(x(i, 1)) If .Exists(s) Then x(i, 1) = .Item(s) Else x(i, 1) = 0 Next i End With
Sheets("W").Range("B1").Resize(UBound(x)).Value = x End Sub
[/vba]
... и немножко с формулами )
[vba]
Код
Sub tttt22() Dim rng As Range, x, i&, s$
With Sheets("Data") Set rng = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row) End With With Sheets("W") If .FilterMode Then .ShowAllData x = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With With WorksheetFunction For i = 1 To UBound(x) x(i, 1) = .VLookup(Trim(x(i, 1)), rng, 2, 0) Next i End With Sheets("W").Range("B1").Resize(UBound(x)).Value = x End Sub
хочу совсем избавится от вычислений на листе, т.е. совсем не вставлять формулу, и сделать так, чтобы все вычисления производились внутри макроса
Можно еще вот так, с использованием формулы в почти привычном виде (т.е. без перехода к аналогичным методам VBA), но БЕЗ помещения формулы в ячейки листа: [vba]
Код
Sub Test3() Dim arr(1 To 21, 1 To 1), i For i = 1 To 21 arr(i, 1) = Application.Evaluate("=IFERROR(INDEX(Data!$B$1:$B$30,MATCH(TRIM($A" & i & "),Data!$A$1:$A$30,0),1),0)") Next i Range("B1:B21") = arr End Sub
хочу совсем избавится от вычислений на листе, т.е. совсем не вставлять формулу, и сделать так, чтобы все вычисления производились внутри макроса
Можно еще вот так, с использованием формулы в почти привычном виде (т.е. без перехода к аналогичным методам VBA), но БЕЗ помещения формулы в ячейки листа: [vba]
Код
Sub Test3() Dim arr(1 To 21, 1 To 1), i For i = 1 To 21 arr(i, 1) = Application.Evaluate("=IFERROR(INDEX(Data!$B$1:$B$30,MATCH(TRIM($A" & i & "),Data!$A$1:$A$30,0),1),0)") Next i Range("B1:B21") = arr End Sub
Sub Teast() Dim rCell As Range, rCel As Range For Each rCell In ThisWorkbook.Worksheets("W").Range("A1:A21") For Each rCel In ThisWorkbook.Worksheets("Data").Range("A1:A21") If rCell = rCel Then rCell.Offset(, 1) = rCel.Offset(, 1) Exit For End If Next rCel Next rCell End Sub
[/vba]
Добрый день!
И еще вариант [vba]
Код
Sub Teast() Dim rCell As Range, rCel As Range For Each rCell In ThisWorkbook.Worksheets("W").Range("A1:A21") For Each rCel In ThisWorkbook.Worksheets("Data").Range("A1:A21") If rCell = rCel Then rCell.Offset(, 1) = rCel.Offset(, 1) Exit For End If Next rCel Next rCell End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
