formatting my copied data

[rjhe22]

hi
have this vb code that copies data i want from one to excel sheet to another
here is code

Sub Exporting_Data1()
Dim i As Long, LR As Long
Application.ScreenUpdating = False
On Error Resume Next

Set ms = Sheets("Sheet2")
    With Worksheets("Sheet1")
        LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
          For i = 1 To LR
             If IsDate(.Cells(i, 1)) Then
                 .Cells(i, 1).Copy
                ms.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End If
                If Len(.Cells(i, "AD")) And .Cells(i, "AD") = "FUND OWNERSHIP %" Then
                .Cells(i, "AD").Offset(1).Resize(4).Copy
                ms.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
              End If
          Next i
    End With
                
Application.CutCopyMode = 0
Columns(1).NumberFormat = "dd/mm/yyyy"
Application.ScreenUpdating = True

End Sub

now the code does work to a certain point. it copies it over and this is how it looks when it does

DATE	       NOK/IA1	Monthly Average	NOK/IA2	Monthly Average	NOK/RA1	Monthly Average	NOK/RA 2	Monthly Average
01/11/2012	0.00%	20.71%	        76.01%	3.28%

i need it to look like this

DATE	       NOK/IA1	Monthly Average	NOK/IA2	Monthly Average	NOK/RA1	Monthly Average	NOK/RA 2	Monthly Average
01/11/2012	0.00%	                 20.71%	                 76.01%	                3.28%

any ideas how i can get it to copy over like this

[Nightwalker83]

Are you doing this from within Office or VB6?

[rjhe22]

doin it within office

[Hack]

In the case your thread would be better served in the Office Development forum section so I have moved.

[rjhe22]

can anyone help with this

[rjhe22]

anyone any ideas on this

[vbfbryce]

It would be easier to step through if you uploaded a zipped version of your workbook. I'm having trouble simulating what you're trying to do.

[rjhe22]

ok sorry
here is a zip file i put it into one book to make it easier

sheet1 is the file i get in shhet2 is how it looks after i run my code and sheet3 is how i want it to look.
here is my file
Book5.zip
and here is code again.

Sub FUND_OWNERSHIP()
Dim i As Long, LR As Long
Application.ScreenUpdating = False
On Error Resume Next

    
    
     Set ms = Workbooks("Book4.xlsx").Sheets("Allocation")
    With Worksheets("Allocation")

        LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
          For i = 1 To LR
             If IsDate(.Cells(i, 1)) Then
                 .Cells(i, 1).Copy
                ms.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End If
                If UCase$(.Cells(i, 30).Value) = "FUND OWNERSHIP %" Then
                                              
                .Cells(i, "AD").Offset(1).Resize(4).Copy
                Debug.Print
                ms.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
              End If
          Next i
    End With
          
Application.CutCopyMode = 0
Columns(1).NumberFormat = "dd/mm/yyyy"
Application.ScreenUpdating = True

End Sub

[vbfbryce]

Try something more like this (sub in the right names for your sheets, etc.):

Sub copyData()
    Dim wsData As Worksheet
    Dim wsCopyTo As Worksheet
    Dim i As Long
    Dim LR As Long
    
    Set wsData = Worksheets("Sheet1")
    Set wsCopyTo = Worksheets("Sheet2")
    LR = wsData.Range("a" & Rows.Count).End(xlUp).Row
    
    For i = 1 To LR
        If IsDate(wsData.Range("a" & i).Value) Then
            wsData.Range("a" & i).Copy
            wsCopyTo.Range("a" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
            wsData.Range("ad" & i + 3).Copy
            wsCopyTo.Range("b" & Rows.Count).End(xlUp).Offset(1).PasteSpecial   'd,f,h
            wsData.Range("ad" & i + 4).Copy
            wsCopyTo.Range("d" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
            wsData.Range("ad" & i + 5).Copy
            wsCopyTo.Range("f" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
            wsData.Range("ad" & i + 6).Copy
            wsCopyTo.Range("h" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
        End If
    Next i
    
End Sub