Copy and paste a row in a new worksheet VBA

[Naislou]

Hello everyone,

I hope you are well. I am new to this forum. The reason I am coming is that I have never used VBA code until now.
I basically want to extract specific columns in a defined order and with the name of a cell (cell A1) of the file I am copying from.
I have come up with this code It sometimes work with less columns but eventually it comes up with an issue on the Range line.

Can someone help me please?:crying:
Thank you!!
Sub Macro1()
'Step 1 Copy the data
Sheets("Data").Range("A11:A5000,B11:B5000,U11:U5000,V11:V5000,W11:W5000,X11:X5000,C11:C5000,E11:E 5000,DA11:DA5000,L11:L5000,G11:G5000,J11:J5000,BQ11:BQ5000,BR11:BR5000,BS11 :BS5000,BV11:BV5000,CG11:CG5000,N11:N5000,P11:P5000,AP11:AP5000,AQ11:AQ5000 ,AS11:AS5000,AT11:AT5000,AU11:AU5000,BG11:BG5000,AV11:AV5000,AW11:AW5000,AX 11:AX5000,AY11:AY5000").Copy
'Step 2 Create a new workbook
Workbooks.Add
'Step 3 Paste the data
ActiveSheet.Paste Destination:=Range("A1")
'Step 4 Turn off application alerts
Application.DisplayAlerts = False
'Step 5 Save the newly created workbook
ActiveWorkbook.SaveAs _
Filename:="C:TempMyNewBook.xlsx"
'Step 6 Turn application alerts back on
Application.DisplayAlerts = True End Sub

[mana]

Sub test()
Dim wsS As Worksheet
Dim wsD As Worksheet
Dim s As String
Dim col
Dim n As Long

Set wsS = Sheets("Data")
Set wsD = Workbooks.Add(xlWBATWorksheet).Sheets(1)
s = "A,B,U,V,W,X,C,E,DA,L,G,J,BQ,BR,BS,BV,CG,N,P,AP,AQ,AS,AT,AU,BG,AV,AW,AX,AY"

For Each col In Split(s, ",")
n = n + 1
wsS.Columns(col).Rows("11:5000").Copy wsD.Cells(n)
Next

Application.DisplayAlerts = False
wsD.Parent.SaveAs ThisWorkbook.Path & "\" & wsS.Cells(1).Value, xlOpenXMLWorkbook
Application.DisplayAlerts = True

End Sub

[paulked]

Not as slick as Mana's!


Sub PaulKed()
Dim wb1 As Workbook
Set wb1 = ThisWorkbook
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:TempMyNewBook.xlsx"
wb1.Sheets("Data").Range("A11:C5000").Copy Sheets("Sheet1").Range("A1")
wb1.Sheets("Data").Range("E11:E5000").Copy Sheets("Sheet1").Range("E1")
wb1.Sheets("Data").Range("J11:J5000").Copy Sheets("Sheet1").Range("J1")
wb1.Sheets("Data").Range("L11:L5000").Copy Sheets("Sheet1").Range("L1")
wb1.Sheets("Data").Range("N11:N5000").Copy Sheets("Sheet1").Range("N1")
wb1.Sheets("Data").Range("P11:P5000").Copy Sheets("Sheet1").Range("P1")
wb1.Sheets("Data").Range("U11:X5000").Copy Sheets("Sheet1").Range("U1")
wb1.Sheets("Data").Range("AP11:AQ5000").Copy Sheets("Sheet1").Range("AP1")
wb1.Sheets("Data").Range("AS11:AY5000").Copy Sheets("Sheet1").Range("AS1")
wb1.Sheets("Data").Range("BG11:BG5000").Copy Sheets("Sheet1").Range("BG1")
wb1.Sheets("Data").Range("BQ11:BS5000").Copy Sheets("Sheet1").Range("BQ1")
wb1.Sheets("Data").Range("BV11:BV5000").Copy Sheets("Sheet1").Range("BV1")
wb1.Sheets("Data").Range("CG11:CG5000").Copy Sheets("Sheet1").Range("CG1")
wb1.Sheets("Data").Range("DA11:DA5000").Copy Sheets("Sheet1").Range("DA1")
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

[Naislou]

Sub test()
Dim wsS As Worksheet
Dim wsD As Worksheet
Dim s As String
Dim col
Dim n As Long

Set wsS = Sheets("Data")
Set wsD = Workbooks.Add(xlWBATWorksheet).Sheets(1)
s = "A,B,U,V,W,X,C,E,DA,L,G,J,BQ,BR,BS,BV,CG,N,P,AP,AQ,AS,AT,AU,BG,AV,AW,AX,AY"

For Each col In Split(s, ",")
n = n + 1
wsS.Columns(col).Rows("11:5000").Copy wsD.Cells(n)
Next

Application.DisplayAlerts = False
wsD.Parent.SaveAs ThisWorkbook.Path & "\" & wsS.Cells(1).Value, xlOpenXMLWorkbook
Application.DisplayAlerts = True

End Sub


Thank you Mana!! that's amazing, the only thing I have a problem with is that when I filter my data on the original document and when I click on the macro you created it copies all rows and not the filtered rows. Is there an easy way to update your beautiful code?

Thank you!
Anais

[Naislou]

Thank you Paul! It did come up with an issue on the save as line but couldn't figure why. Mana's code is working but thank you so much for your support:thumb

Anais