Do While Method to append data

[sbbmaster09]

I am able to do this in using one file, how can I insert do while or for loop where the copydata will be merged/append on the final data. I think there is a tweak on the RunCopy code below to be able to append data from one sheet to another. I am not much familiar with do while loops.

Sub RunCopy()Dim i As Long, x As Range


With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With


With Sheet2
    For i = .UsedRange.Columns.Count To 1 Step -1
        Set x = Sheet3.Rows(1).Find(.Cells(1, i).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not x Is Nothing Then
                .Columns(i).Value = Sheet3.Columns(x.Column).Value
            End If
        Set x = Nothing
    Next i
End With


With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With


End Sub

Attached file for reference. Thanks.

[Jacob Hilderbrand]

In this example it uses With Sheet2 so anything that starts with a . is on Sheet2. And also uses Sheet3. So it copies from Sheet2 to Sheet3 and columns are processed one at a time. What are you trying to loop?

[offthelip]

On the assumption that you want append the data to rows below the first set this code will copy the data to subsequent rows. I was looking at the workbook that you sent so I have used those sheet names. plus "Test" the output. Note I haven't defined all the variables, since this is only a suggestion as to how to do it. Note I am using Variant array instead of copy from colunm to column, this should be much faster since every access to the worksheet in EXCEL takes a long time.
I hope this gives you some ideas in solving your problem




[VBA]Sub Newruncopy()
Dim i As Long, x, lastcell As Range
Dim outarr() As Variant


With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With


indi = 0


For dummy = 1 To 2


Worksheets("finaldata").Select
colcnt = Worksheets("finaldata").UsedRange.Columns.Count
With Worksheets("finaldata")
Set lastcell = .Cells(.Rows.Count, "A").End(xlUp)
rowcnt = lastcell.Row
End With
inarr = Range(Cells(1, 1), Cells(rowcnt, colcnt))
ReDim outarr(1 To rowcnt, 1 To colcnt)
Worksheets("Copydata").Select
titles = Range(Cells(1, 1), Cells(1, 14))


For i = 1 To 14
outarr(1, i) = titles(1, i)
For j = 1 To colcnt
If titles(1, i) = inarr(1, j) Then
For k = 2 To rowcnt
outarr(k, i) = inarr(k, j)
Next k
End If
Next j
Next i


Worksheets("test").Select
Range(Cells(1 + indi, 1), Cells(rowcnt + indi, colcnt)) = outarr


indi = indi + rowcnt
Next dummy


With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub


[/VBA]

[sbbmaster09]

I will check on this and study, I will give a feedback once done. thanks for this.

[sbbmaster09]

It's not working for me, it won't append the data from the copy data to the finaldata.

[sbbmaster09]

I have tried to debug my code, I came up with this code and has a lil error than before. Can someone check where I have done wrong? It seems that i am able to transfer all the data from the copydata tab to the finaldata tab but in a different cell, attached is my file.

    Sheet1.Select    Range("F" & cnt).Value = RowCount
    
    Sheet2.Select
    rn = Sheet2.UsedRange.Rows(Sheet2.UsedRange.Rows.Count).Row
    
    For i = 1 To Sheet2.UsedRange.Columns.Count Step 1
        Set x = Sheet3.Rows(1).Find(Sheet2.Cells(1, i).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not x Is Nothing Then
                Sheet3.Select
                Cells(2, x.Column).Select
                Range(Selection, Selection.End(xlDown)).Copy


                Sheet2.Select
                Cells(rn + 1, i).Select
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                    xlNone, SkipBlanks:=False, Transpose:=False
            End If
        Set x = Nothing
    Next i
    
    Sheet2.Select
    Range("A" & RowCount + 1).Select
    Range(Selection, Selection.End(xlUp).Offset(1)).Value = Sheet1.Range("D" & cnt).Value
    Sheet1.Select

[offthelip]

It's not working for me, it won't append the data from the copy data to the finaldata.

the code that I wrote doesn't write out to the Finaldata sheet, it writes the data out to a sheet called "Test" which I added to your workbook for testing. The code just writes the same lines out twice because the data in copydata doesn't change. So this is only part of the solution, but it will append data to rows below, but only with in the loop. I noticed that you have commented out these lines in the workbook you sent back.

Can you clarify what the sequence of events is when you want to append data to the bottom of final data? Is the data in Copydata changing in between calls to this macro? Do you want the macro to determine where to append data to in final worksheet.

In your code you are using "used range" to determine the last row, you will find that the used range is usually much larger than the range which has actually got data in it. I would suggest using the code I used to determine the last cell with data in it. (your variable "rn")

[VBA]Set lastcell = .Cells(.Rows.Count, "A").End(xlUp)
rowcnt = lastcell.Row[/VBA]

You might find that this solves your problem anyway. It certainly will cause your code to paste the data way beyond the last row with data in it.

[sbbmaster09]

I finally solved it.

    Range("A2").Select    RowCount = ActiveSheet.UsedRange.Rows.Count - 1


    rn = Sheet2.Range("A1").CurrentRegion.Rows.Count


    Sheet2.Select
    Range("A" & rn + 1 & ":A" & RowCount + rn).Value = Sheet1.Range("D" & cnt).Value
    
    Sheet1.Select
    Range("F" & cnt).Value = RowCount
    
    Sheet2.Select
    
        For i = 1 To Sheet2.UsedRange.Columns.Count Step 1
            Set x = Sheet3.Rows(1).Find(Sheet2.Cells(1, i).Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not x Is Nothing Then
                    Sheet3.Select
                    Cells(2, x.Column).Select
                    Range(Selection, Selection.End(xlDown)).Copy
    
                    Sheet2.Select
                    Cells(rn + 1, i).Select
                    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                        xlNone, SkipBlanks:=False, Transpose:=False
                End If
            Set x = Nothing
        Next i