Do Until Loop to Paste Information Vertically

[rarexcel]

Hi everyone. I could really use some help getting the following code to work. In my spreadsheet budget data is displayed horizontally by month.

Oct-10 Nov-10
2000 500
2345 1111
1233

I need it to be displayed vertically with the month next to each expense.

Oct-10 2000
Oct-10 2345
Oct-10 1233
Nov-10 500
Nov-10 1111

When I run the following code it seems to copy the first month of data multiple times instead of copying the first month down, and then moving to the next month and copying it below it.

I also run into Error '1004' to do with copying and/or pasting.

Sub CopyMonthlyBudgetDown()

    Dim Y As Integer
    Dim w As Long
    Dim B As Long
    Dim n As Long
     
'This gives me how many columns of data need to be copied     
Let Y = Worksheets("APExport").Range("A1:ZZ1").Cells.SpecialCells(xlCellTypeConstants).Count
    
   Do Until B = Y
         'The first expense is at (2,5) 
         B = 5
         n = 2
         
         'This finds the cell where the expenses should be pasted 
         Sheets("APExport").Range("D1").Select
         Selection.End(xlDown).Select
         ActiveCell.Offset(1, 0).Select
         c = ActiveCell.Address
         
         'This selects the expenses to be copied
         Sheets("APExport").Cells(n, B).Select
         Range(Selection, Selection.End(xlDown)).Select
         ActiveSheet.Paste
         B = B + 1
    Loop

End Sub

Cheers!

 

[VoG]

Code with all that selecting is both inefficient and difficult to follow. Please post a small example of before and after using Excel Jeanie http://www.excel-jeanie-html.de/html/hlp_schnell_en.php

 

[rarexcel]

I think I solved my own issue! Here is the new code in case anyone stumbles across this and it can help solve their problems, too.

Sub CopyMonthlyBudgetDown()

    Dim Y As Integer
    Dim B As Integer
     
    Y = Worksheets("APExport").Range("A1:ZZ1").Cells.SpecialCells(xlCellTypeConstants).Count
    
    B = 5
    
    Do Until B = Y + 1
         Sheets("APExport").Range("D1").Select
         Selection.End(xlDown).Select
         ActiveCell.Offset(1, 0).Select
         c = ActiveCell.Address
         Sheets("APExport").Cells(2, B).Select
         Range(Selection, Selection.End(xlDown)).Copy Destination:=Range(c)
         B = B + 1
    Loop

End Sub