Цикл: найдите строку на основе списка и отрегулируйте конечные нули и вокруг границы на другом листе

Question

Сводка: найдите текст / строку на основе списка на другом листе и отрегулируйте конечные нули с границей вокруг диапазона.

Книга Excel, содержащая два листа. Имя листа1: список (имеющий столбец A с текстом / строкой для поиска и столбец B с числовым значением), как на первом изображении.

Имя листа 2. «Необработанный», содержащий текст в любом месте и ниже числового значения с разными десятичными точками. Также есть несколько пустых строк между наборами диапазонов, как на рисунке 2.

Я записал макрос и попытался его отредактировать. Этот макрос работает для Text1. Ниже макроса найдите text1 в «сыром» листе и настройте отображение конечных нулей на основе значения B1 листа списка.

Как зациклить весь перечисленный текст в столбце А списка листов и настроить отображение конечных нулей с внешними границами. Вывод на изображение 3. Найти как xlpart.

Лист1 или список

Лист2 или другой лист

выход

Sub Macro1()

Dim sFirstAddress As String
Dim rng As Excel.Range


 With Sheets("Raw").Range("A1:DZ1000") '.UsedRange ???
'how to loop for list of text/string present in column A as in image 1.

 Set C = .Find(What:="Text1", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
    SearchFormat:=False)
If Not C Is Nothing Then
    FirstAddress = C.Address
    Do

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.Offset(1, 0).Select

Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'how to loop for number in column B for adjusting/Keeping trailing zero's

If Sheets("List").Range("B1") = 1 Then
Selection.NumberFormat = "0.0"
Else
If Sheets("List").Range("B1") = 2 Then
Selection.NumberFormat = "0.00"
Else
If Sheets("List").Range("B1") = 3 Then
Selection.NumberFormat = "0.000"

End If
End If
End If

Selection.End(xlDown).Select
Cells.FindNext(After:=ActiveCell).Activate


Set C = .FindNext(C)
    If C Is Nothing Then
        GoTo DoneFinding
    End If
    Loop While C.Address <> FirstAddress
  End If
DoneFinding:
End With

End Sub

Answer 1

Выполняя метод проб и ошибок непрерывно в течение 6 часов, я могу зациклить оба столбца списка и вывести результат, как и ожидалось.Ниже код работает отлично.

Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim Rng As Range
Dim I As Long

Dim item As Range




For Each item In Sheets("List").UsedRange.Columns("A").Cells

MySearch = Array(item.Value2)
If item.Value2 = "" Then
Exit Sub
Else

With Sheets("Raw").UsedRange 'Range("B1:AA10000")


   For I = LBound(MySearch) To UBound(MySearch)



        Set Rng = .Find(What:=MySearch(I), After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=True, SearchFormat:=False)


        If Not Rng Is Nothing Then
            FirstAddress = Rng.Address

            Do
                    With Rng.Borders
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 0
                        .TintAndShade = 0
                    End With


                   Rng.Offset(1, 0).Select

                    Range(Selection, Selection.End(xlDown)).Select
                    If item.Offset(, 1).Value2 = 1 Then
                    Selection.NumberFormat = "0.0"

                        Else
                    If item.Offset(, 1).Value2 = 2 Then
                    Selection.NumberFormat = "0.00"

                        Else
                    If item.Offset(, 1).Value2 = 3 Then
                    Selection.NumberFormat = "0.000"

                    Else
                    If item.Offset(, 1).Value2 = 4 Then
                    Selection.NumberFormat = "0.0000"
                        End If
                        End If
                        End If
                    End If



                    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
                    Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
                    Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
                    Selection.Borders(xlEdgeTop).LineStyle = xlContinuous

                Set Rng = .FindNext(Rng)


            Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress

       End If

    Next I
End With
End If
Next
End Sub