Блог

Главная - Вопросы по программированию - Как перебирать отдельные ячейки массива

Как перебирать отдельные ячейки массива

#excel #vba #loops

#excel #vba #циклы

Вопрос:

Унаследовал макрос, в котором я не на 100%, и мне нужно это исправить. По сути, он должен проверять, заполнены ли все ссылочные ячейки, если true — скопируйте в ячейку плана, если пусто, ничего не делайте. Однако, похоже, он копирует независимо.

введите описание изображения здесь

Пробовал добавлять для каждого цикла, но, похоже, не вступает в силу.

 refGap = findRefGap(refCol, LR, valToCopy)
planGap = findPlanGap(refCol, LR)



For i = 23 To LR
    'Checks to see if the cell is actually referencing a product.
    If IsEmpty(Cells(i, prodCol).value) = False And Cells(i, prodCol).value <> "Result" Then
'        RefPt is the row where ref demand is found, same with planPt to planned non-promoted volume.
        refPt = i   refGap
        planPt = i   planGap

        Range(Cells(refPt, calCol), Cells(refPt, LC)).copy
        Range(Cells(planPt, calCol), Cells(planPt, LC)).PasteSpecial xlPasteValues

    End If
Next

Комментарии:

1. Вы убедились, что ячейки не пустые (без пробелов) и что точная строка не является «Результатом» Like "Result" ?

2. Привет, Кирилл, да, я проверил, что ячейки полностью пусты. Даже использовалась формула в интерфейсе Excel для проверки isblank = true. Спасибо

3. Вместо использования буфера обмена вы можете сделать Range(Cells(planPt, calCol), Cells(planPt, LC)).Value = Range(Cells(refPt, calCol), Cells(refPt, LC)).Value . Обратите внимание, что если этот код не написан в коде какого-либо модуля рабочего листа, он неявно ссылается на ActiveSheet . Неквалифицированным вызовам Cells и Range должен предшествовать Worksheet объект и точка, например Sheet1.Cells(...) .

4. Есть On Error Resume Next где-нибудь в этой процедуре? Если это так, удалите это: если Cells(i, prodCol).Value содержит ошибку рабочего листа, <> "Result" сравнение выдает ошибку несоответствия типа и Resume Next нарушает условие и делает весь блок безусловным в этих случаях.

5. На самом деле здесь недостаточно информации, чтобы указать на что-то и сказать «в этом проблема». Это действительно выиграло бы от предоставления образцов данных и ожидаемых результатов. Также было бы очень полезно, если бы вы опубликовали полный код, а не только фрагмент, поскольку фрагмент выглядит действительным как есть.

Ответ №1:

Возможно, что-то вроде этого?

 Sub tgr()

    Dim ws As Worksheet
    Dim rPlan As Range
    Dim rReference As Range
    Dim sHeadersCol As String
    Dim sFirst As String
    Dim lCol As Long

    Set ws = ActiveWorkbook.ActiveSheet
    sHeadersCol = "A"

    Set rPlan = ws.Columns(sHeadersCol).Find("Plan", ws.Cells(ws.Rows.Count, sHeadersCol), xlValues, xlWhole)
    If Not rPlan Is Nothing Then
        sFirst = rPlan.Address
        Do
            Set rReference = ws.Range(rPlan, rPlan.End(xlDown)).Find("Reference", rPlan, xlValues, xlWhole)
            If Not rReference Is Nothing Then
                For lCol = rPlan.Column   1 To rPlan.Column   rPlan.CurrentRegion.Columns.Count - 1
                    If Len(Trim(ws.Cells(rReference.Row, lCol).Value)) > 0 Then ws.Cells(rPlan.Row, lCol).Value = ws.Cells(rReference.Row, lCol).Value
                Next lCol
            End If
            Set rPlan = ws.Columns(sHeadersCol).Find("Plan", rPlan, xlValues, xlWhole)
        Loop Until rPlan.Address = sFirst
    End If

End Sub