Excel VBA - Why is my cell value not being appended? - vba

Question

I currently have a script (See Below) that adds the contents of every cell in the used rows to another cell in a different worksheet. However, this works for the first 3 cells but will not work for the last 2 for some reason.
Sub Ready_For_Infra()
Dim i As Integer
Dim k As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
For i = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row Step 1
For k = 1 To ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
With Worksheets("InfraData")
If ws2.Cells(k, i).Value <> "" Then
ws1.Range("A" & i).Value = ws1.Range("A" & i).Value & ws2.Cells(i, k).Value & Chr(10)
End If
End With
Next k
Next i
MsgBox "Done"
End Sub
This is the data in ws2 (ActionPlan) just in case it helps:
To clarify, it doesn't appear to be appending Cells D2:F3 to the cells I have asked it to. Is anyone able to advise why this might be the case?

Answer 1

Try this code:
Sub Ready_For_Infra()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range
Dim i As Long, lastrow As Long, lastcol As Long
Dim str1 As String
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
With ws2
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To lastrow
str1 = ""
For Each cell In .Range(.Cells(i, 1), .Cells(i, lastcol))
If cell.Value <> "" Then str1 = str1 & cell.Value & Chr(10)
Next cell
ws1.Range("A" & i).Value = str1
Next i
End With
MsgBox "Done"
End Sub
Notes:
using For each loop is slightly faster then For k=1 To lastcol
using temporary string variable str1 makes your code faster as well, because in that case you writes result value in ws1.Range("A" & i) cell only once (working with operating memory is always faster than writing subresult in cell for each iteration).