Copy Pasting data from one excel workbook to another using vba

**wahaj** · 05-08-2009, 12:34 PM

Hi Guys,

I'm a newbie at vba. I want to write a vba script that copies 73 cells from a specific row in an excel sheet and pastes them in a single column in 73 rows in a new document. It then goes back to the old document and copies 73 cells from the next row and pastes them in the new document.

I want to do the following things using the macro

1. Open a old.xls document
2. Open a new new.xls workbook
3. Copy a range of data from (D9:BX9) //73 cells from old.xls
4. Paste the copied data from (D2:D74) in new.xls
5. Go back to data.xls document
6. Copy the range from (D10:BX10)
7. Go back to new.xls (opened earlier) and pastes it in (D75:148)
8. Continues in loop until it reaches an empty cell in data.xls
9. Saves the new.xls and exits

I'm trying to use a script I found online and modified a bit. I now just can't make it work. I would be much obliged if someone could help me with this.

Script

Sub Copying()
    Application.ScreenUpdating = False
    MyBook = ActiveWorkbook.Name  ' Get name of this  book
    Workbooks.Add ' Open a new workbook
    ThatBook = ActiveWorkbook.Name ' Save name of new book
    
intRowi = 9
intColis = 4
intColie = 77
intRowo = 2
intColos = 4
intColoe = intColos +73
Do Until objExcel.Cells(intRowi,intColis).Value = ""
    a= objExcel.Cells(intRow, intColumn).Value
Workbooks(MyBook).Activate ' Back to original book
    Worksheets("old").Activate
    Range("intRowi intColis:intRowi intColie").Select
    Selection.Copy
Workbooks(ThatBook).Activate
    Range("intRowo intColos: IntRowo intColoe").Select
    Selection.Paste Paste:=xlValues
    Selection.Paste Paste:=xlFormats

   intRowi = intRow + 1
   intColos = intColoe + 1
   intColoe = intColos +73 
    
Loop

        SaveAs ("C:\new.xls")
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

**ravishankar** · 05-08-2009, 01:22 PM

HI
try the following codes. change sheet name and workbook name if they are different.

Sub transpose()
Dim x As Long
x = Workbooks("Old.xls").Worksheets("Data").Cells(Rows.Count, 4).End(xlUp).Row
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="wahaj.xls"
Workbooks("Old.xls").Worksheets("Data").Range("D9:BX" & x).Copy
Worksheets("Sheet1").Range("D2").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , transpose:=True
ActiveWorkbook.Save
MsgBox "complete"
End Sub

Ravi

**wahaj** · 05-08-2009, 02:47 PM

Ravi,

Thanks for the reply. The code worked like a charm but with a slight glitch

The cells D9 - BX9 are being copied and pasted to a new sheet,
but instead of being pasted into the same row, one after the other, they are being posted on different rows. What I want is something like,

The first 73 cells copied from D9 - BX9 get pasted from D2 - D74 of the new sheet and D10 - BX10 get pasted on D75- D147 and so on.

Regards

Wahaj

**wahaj** · 05-08-2009, 07:18 PM

The following code does the what I wanted to do, but takes a hell lot of time due to working cell by cell.

Can someone help me in optimizing this baby,so that I can pick ranges instead of cell by cell?

Sub copypaste()
Dim x As Long
x = Workbooks("ATTITUDES.xls").Worksheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="Attitudes3.xls"
Startrow = 9
Pasrow = 2

Do Until Startrow = 150
StartCol = 4

Do Until Workbooks("ATTITUDES.xls").Worksheets("Sheet2").Cells(Startrow, StartCol).Value = ""
Workbooks("ATTITUDES.xls").Worksheets("Sheet2").Cells(Startrow, StartCol).copy
Worksheets("Sheet1").Cells(Pasrow, 4).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, transpose:=False
' Startrow = Startrow + 1
Pasrow = Pasrow + 1
StartCol = StartCol + 1

Loop

Startrow = Startrow + 1
Loop

ActiveWorkbook.Save
MsgBox "complete"
End Sub

**ravishankar** · 05-10-2009, 02:50 AM

HI
try the following codes. Change the filename and sheet name to suit your case

Sub Linear()
Dim x As Long, y As Long, a As Long
x = Cells(Rows.Count, 4).End(xlUp).Row
    For a = 9 To x
    Range("D" & a & ":BX" & a).Copy
    Range("DA" & (a - 9) * 73 + 2).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
            , transpose:=True
    Next a
y = Cells(Rows.Count, 105).End(xlUp).Row
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="wahaj.xls"
Workbooks("Old.xls").Worksheets("Data").Range("DA2:DA" & y).Copy
Sheets("Sheet1").Range("D2").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , transpose:=False
ActiveWorkbook.Save
Workbooks("Old.xls").Worksheets("Data").Range("DA:DA").ClearContents
MsgBox "complete"
End Sub

Ravi