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

levibiessen

New Member
Joined
Apr 24, 2023
Messages
4
Platform
  1. Windows
I am searching for a macro that loops through the table shown in the first image, which is on 'Sheet1'.

Image1.PNG


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'.
Image2.PNG


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.
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
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
 
Upvote 0
Hello. I ask you: Will you always use the same range of cells (D409:CJ412)?
 
Upvote 0
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.
 
Upvote 0
So try with:

VBA Code:
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
 
Upvote 0
So try with:

VBA Code:
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.
 

Attachments

  • Image3.png
    Image3.png
    34.4 KB · Views: 4
Upvote 0
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?...
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,167
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top