Loop through a table in Excel: when a cell contains a value, copy this value to another sheet

[levibiessen]

I am searching for a macro that loops through the table shown in the first image, which is on 'Sheet1'.

The following things need to be done whenever there is a value available in the range of D409:CJ412:

1.Copy the value to another sheet 'Sheet2' and paste it in the column 'Bestede Uren'.

2. Copy the corresponding value in column A of Sheet1, which is the date, and paste it in column Dag_id on Sheet2.
3. Copy the corresponding column value in row 2 of Sheet1, which is the project name, and paste it in the column Project naam on Sheet2.
Every time there is a value available in the table of Sheet1, a new record on Sheet2 must be made and the three steps above should be applied.

Thanks in advance.

 

[levibiessen]

I am searching for a macro that loops through the table shown in the first image, which is on 'Sheet1'.

View attachment 90319

The following things need to be done whenever there is a value available in the range of D409:CJ412:

1.Copy the value to another sheet 'Sheet2' and paste it in the column 'Bestede Uren'.
View attachment 90321

2. Copy the corresponding value in column A of Sheet1, which is the date, and paste it in column Dag_id on Sheet2.
3. Copy the corresponding column value in row 2 of Sheet1, which is the project name, and paste it in the column Project naam on Sheet2.
Every time there is a value available in the table of Sheet1, a new record on Sheet2 must be made and the three steps above should be applied.

Thanks in advance.

I have so far created the following code:

Sub uren()
'
' uren Macro
'

'

For j = 0 To 4 'amount of rows

For i = 0 To 80 'Amount of columns


If IsNumeric(Range("D409").Offset(0, 1).Value) Then

'Copy date of column A
Range("A409").Offset(0, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A2").Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Sheets("Sheet1").Select
Range("D409").Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("B2").Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("D2").Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("C2").Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = -45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End If
Next i
End
Next j
End
End Sub

 

[Mario_R]

Hello. I ask you: Will you always use the same range of cells (D409:CJ412)?

 

[levibiessen]

Hello. I ask you: Will you always use the same range of cells (D409:CJ412)?

In this document I will. When a new document is received there may be aditional projects, by which the column 'CJ' has to be changed. Furthermore, new data will then be present from row 413 onwards.

 

[Mario_R]

So try with:

Sub Macro_8()
Dim LC%, C As Range, a, Q&, D As Range
Application.ScreenUpdating = False
'--------------->
With Sheets("Sheet1")
  LC = .Cells(2, Columns.Count).End(xlToLeft).Column
  ReDim a(1 To 3, 0 To 0): Set C = .Range("A409")
'--------------->
  Do While C <> Empty
    If C(1, 3).End(xlToRight).Column <= LC Then
      For Each D In C(1, 4).Resize(, LC - 3).SpecialCells(2, 1)
        Q = 1 + Q
        If Q > UBound(a, 2) Then ReDim Preserve a(1 To 3, 1 To 10 + UBound(a, 2))
        a(1, Q) = C: a(2, Q) = D: a(3, Q) = .Cells(2, D.Column)
      Next
    End If
    Set C = C(2)
  Loop
'--------------->
End With
'--------------->
With Sheets("Sheet2")
  .Cells(1).CurrentRegion.Offset(1).Delete xlShiftUp
  .Range("A2").Resize(Q, 3) = Application.Transpose(a)
End With
'--------------->
End Sub

 

[levibiessen]

So try with:

Sub Macro_8()
Dim LC%, C As Range, a, Q&, D As Range
Application.ScreenUpdating = False
'--------------->
With Sheets("Sheet1")
  LC = .Cells(2, Columns.Count).End(xlToLeft).Column
  ReDim a(1 To 3, 0 To 0): Set C = .Range("A409")
'--------------->
  Do While C <> Empty
    If C(1, 3).End(xlToRight).Column <= LC Then
      For Each D In C(1, 4).Resize(, LC - 3).SpecialCells(2, 1)
        Q = 1 + Q
        If Q > UBound(a, 2) Then ReDim Preserve a(1 To 3, 1 To 10 + UBound(a, 2))
        a(1, Q) = C: a(2, Q) = D: a(3, Q) = .Cells(2, D.Column)
      Next
    End If
    Set C = C(2)
  Loop
'--------------->
End With
'--------------->
With Sheets("Sheet2")
  .Cells(1).CurrentRegion.Offset(1).Delete xlShiftUp
  .Range("A2").Resize(Q, 3) = Application.Transpose(a)
End With
'--------------->
End Sub

It says that no cells are found on the yellow line.

 

[Mario_R]

The VBA code shown works perfectly.
So the error you see is a consequence of the fact that the real model is not the same as the one you showed in your first post.

Can you upload your implementation to a free server like MediaFire or similar?...