Страницы: 1
RSS
Поиск ячеек со значениями больше ноля и вывод их адресов
 
Здравствуйте! Мне необходимо найти все значения больше 0,01 во второй строке, где есть и цифры, и текст, и вывести их адреса в столбик на втором листе. Если это не сильно затруднит задачу, то значения больше 0,01 нужно искать во второй строке в столбцах В, Е, Н и далее через каждые два столбца до первой пустой ячейки в строке (там цепочка обрывается). Заранее спасибо!
 
, запускать с активным 1 листом  не понятрно зачем вам адреса ячеек
Код
Sub mrshkei()
Dim arr, i As Long, lr As Long
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
ReDim arr(1 To 1)
For i = 2 To lcol Step 3
    If Cells(2, i) > 0.01 Then arr(UBound(arr)) = Cells(2, i).Address: ReDim Preserve arr(1 To UBound(arr) + 1)
Next i
Worksheets(2).Range("A1").Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Спасибо, милый человек!
 
Еще вариант
Код
Sub SENfdjh()
    Dim Rg1 As Range, Rg2 As Range, Tp1, Col1 As New Collection, Arr1, i&
Set Rg1 = Sheets(1).Range(Cells(2, 1), Cells(2, 1).End(xlToRight))
    For Each Tp1 In Rg1.Cells
If Tp1 > 0.01 And ((Tp1.Column + 1) Mod 3) = 0 Then Col1.Add Tp1.Address
    Next
ReDim Arr1(1 To Col1.Count): For Each Tp1 In Col1
    i = i + 1: Arr1(i) = Tp1: Next
Sheets(2).Cells(1).Resize(UBound(Arr1)) = WorksheetFunction.Transpose(Arr1)
End Sub
 
Код
=АДРЕС(2;ФИЛЬТР.XML("<j><i>"&ПОДСТАВИТЬ(ОБЪЕДИНИТЬ(СИМВОЛ(1);1;ПОДСТАВИТЬ((B2:R2>0.01)*(ЕЧИСЛО(B2:R2))*(ОСТАТ(СТОЛБЕЦ(B2:R2);1.5)=0.5)*СТОЛБЕЦ(B2:R2);0;"а"));СИМВОЛ(1);"</i><i>")&"</i></j>";"//i[not(contains(.,'а'))]");1)
 
=IFERROR(ADDRESS(2;SMALL(IF((Лист1!$A$2:$R$2>0,1)*(MOD(COLUMN($A$2:$R$2)-2;3)=0);COLUMN($A$2:$R$2));ROWS($A$1:A1));4);"")
По вопросам из тем форума, личку не читаю.
 
Здравствуйте! Прошу первый вариант макроса адаптировать таким образом, чтобы его можно было запускать из другой книги. Спасибо!
 
Код
Option Explicit

Const WBNAME = "Больше ноля.xlsm"

Sub mrshkei_wb()
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(WBNAME)
    On Error GoTo 0
    
    If wb Is Nothing Then
        MsgBox "Откройте книгу " & WBNAME, vbExclamation
    Else
        mrshkei wb.Sheets(1), ThisWorkbook.Sheets(1)
    End If
End Sub

Sub mrshkei(shIn As Worksheet, shOut As Worksheet)
    With shIn
        Dim arr, i As Long, lr As Long
        Dim lcol As Long
        lcol = .Cells(2, Columns.Count).End(xlToLeft).Column
        ReDim arr(1 To 1)
        Dim brr As Variant
        brr = .Range(.Cells(2, 1), .Cells(2, lcol))
        For i = 2 To lcol Step 3
            If brr(1, i) > 0.01 Then arr(UBound(arr)) = Cells(2, i).Address: ReDim Preserve arr(1 To UBound(arr) + 1)
        Next i
    End With
    shOut.Range("A1").Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
End Sub
 
Ничего не получается. Программа пишет, откройте книгу "Больше ноля", хотя книга открыта.
Нельзя ли сделать что-то вроде:
Код
Sub mrshkei()
Workbooks("Больше ноля.xlsm").Activate
Sheets("Лист1").Select
Dim arr, i As Long, lr As Long
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
ReDim arr(1 To 1)
For i = 2 To lcol Step 3
    If Cells(2, i) > 0.01 Then arr(UBound(arr)) = Cells(2, i).Address: ReDim Preserve arr(1 To UBound(arr) + 1)
Next i
Sheets("Лист2").Range("A1").Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
End Sub
Но чтобы этот макрос находился в "Другая книга".

Спасибо!
 
Цитата
написал:
Нельзя ли сделать что-то вроде:
Кто ж нам запретит?
Код
Sub mrshkei()
Workbooks("Больше ноля.xlsm").Activate
Sheets("Лист1").Select
Dim arr, i As Long, lr As Long
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
ReDim arr(1 To 1)
For i = 2 To lcol Step 3
    If Cells(2, i) > 0.01 Then arr(UBound(arr)) = Cells(2, i).Address: ReDim Preserve arr(1 To UBound(arr) + 1)
Next i
Sheets("Лист2").Range("A1").Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
End Sub
 
Извините за назойливость, но теперь нужно получить адреса в формате Cell(1,1).
Address: ReDim Preserve arr(1 To UBound(arr) + 1)
Изменено: Platon - 06.12.2021 15:38:02
 
Код
Sub mrshkei()
Workbooks("Больше ноля.xlsm").Activate
Sheets("Лист1").Select
Dim arr, i As Long, lr As Long, lcol As Long
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
ReDim arr(1 To 1)
For i = 2 To lcol Step 3
    If Cells(2, i) > 0.01 Then arr(UBound(arr)) = "Cells(2," & i & ")": ReDim Preserve arr(1 To UBound(arr) + 1)
Next i
Sheets("Лист2").Range("A1").Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
End Sub
Страницы: 1
Наверх