如何在每个单元格上方查找单元格的值

Question

I want to screen all sheets for values that starts with "D" In the sheets I formed blocks (1 column, 4 rows) with - owner - area - parcel (that is allways starting with a "D") - year of transaction (blocks of 1 column and 4 rows).

I want to make a summary in sheet "Test".

I'm able to find the parcel, but how can I get the info from the cell above?

Sub Zoek_kavels()

Dim ws As Worksheet
Dim rng As Range
Dim Area
Dim Kavel As String

rij = 1

For Each ws In ActiveWorkbook.Sheets
    Set rng = ws.UsedRange
    For Each cell In rng
        If Left(cell.Value, 1) = "D" Then             'Starts with D
            Sheets("Test").Cells(rij, 1) = cell.Value       'Kavel D..
            Cells(cell.row - 1, cell.Column).Select
            Area = ActiveCell.Value

            Sheets("Test").Cells(rij, 2) = Area             'Oppervlakte
            Sheets("Test").Cells(rij, 3) = ws.Name          'Werkblad naam
            rij = rij + 1
        End If
    Next
Next

End Sub

Answer 1

There are two important points (and two not so important) to take care of your code:

• start from row 2, because you are using .row - 1 . Thus, if you start at row 1, row-1 would throw an error;
• try to avoid Select , ActiveCell , etc.;( How to avoid using Select in Excel VBA );
• write comments in English, not in Dutch (also good idea for variable names as well, rij or kavel do not help a lot);
• declare the type of your variables, eg dim Area as String or as Long or anything else;

---

Option Explicit

Sub ZoekKavels()

    Dim ws      As Worksheet
    Dim rng     As Range
    Dim Kavel   As String
    Dim rij     As Long
    Dim cell    As Range

    rij = 2 'start from the second row to avoid errors in .Row-1

    For Each ws In ActiveWorkbook.Worksheets
        Set rng = ws.UsedRange
        For Each cell In rng
            If Left(cell, 1) = "D" Then
                With Worksheets("Test")
                    .Cells(rij, 1) = cell
                    .Cells(rij, 2) = ws.Cells(cell.Row - 1, cell.Column)
                    .Cells(rij, 3) = ws.Name
                End With
                rij = rij + 1
            End If
        Next
    Next

End Sub

---

Or you can use .Cells(rij, 2) = cell.Offset(-1, 0) instead of Cells(cell.Row - 1, cell.Column) , as proposed in the comments by @Shai Rado.

Answer 2

A nice simple loop should do the trick, you may have had spaces in the worksheet, that would throw off the used range. Here is a different approach.

   Sub Get_CellAboveD()
    Dim LstRw As Long, sh As Worksheet, rng As Range, c As Range, ws As Worksheet, r As Long

    Set ws = Sheets("Test")

    For Each sh In Sheets
        If sh.Name <> ws.Name Then
            With sh
                LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
                Set rng = .Range("A1:A" & LstRw)
                If LstRw > 1 Then
                    For Each c In rng.Cells
                        If Left(c, 1) = "D" Then
                            r = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
                            ws.Range("A" & r).Value = c
                            ws.Range("B" & r).Value = c.Offset(-1).Value
                            ws.Range("C" & r).Value = sh.Name
                        End If
                    Next c
                End If
            End With
        End If
    Next sh
 End Sub