VBA: Copy X Col to new sheet

harky

Active Member
Joined
Apr 8, 2010
Messages
405
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
I like to copy a marco to copy 'masterlist' sheet of X roll below

HOPE somone can help me :)

B16 C16E16H16Q16AD16R16S16T16U16V16W16X16Y16Z16AA16AB16AC16
to new wk

A2B2C2D2E2F2G2H2I2J2K2L2M2N2O2P2Q2R2

<tbody>
</tbody>
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Try this simple Macro
Code:
Option Explicit


Sub Copy_columns()
Rem =====>>This is a simple example
Dim i%
Dim First_sh As Worksheet
Dim Sec_sh As Worksheet
Dim First_arr(), Sec_arr()
Set First_sh = Sheets("Sheet1") ' Change Sheet1 by the sheet's name of data source
Set Sec_sh = Sheets("Sheet2") ' Change Sheet2  by the sheet's name of data target
First_arr = Array("$B$4", "$c$6", "$e$1") 'Complete the array
Sec_arr = Array("$A$2", "$c$2", "$d$2") 'Complete the array
For i = LBound(Sec_arr) To UBound(Sec_arr)
 Sec_sh.Range(Sec_arr(i)) = First_sh.Range(First_arr(i))
 Next
End Sub
 
Last edited:
Upvote 0
hi,
this isnt what i want.. i want to copy the WHOLE COLUMN. Start from B16 below

ur code only copy 1 row?


i want to copy COLUMN not row.


Try this simple Macro
Code:
Option Explicit


Sub Copy_columns()
Rem =====>>This is a simple example
Dim i%
Dim First_sh As Worksheet
Dim Sec_sh As Worksheet
Dim First_arr(), Sec_arr()
Set First_sh = Sheets("Sheet1") ' Change Sheet1 by the sheet's name of data source
Set Sec_sh = Sheets("Sheet2") ' Change Sheet2  by the sheet's name of data target
First_arr = Array("$B$4", "$c$6", "$e$1") 'Complete the array
Sec_arr = Array("$A$2", "$c$2", "$d$2") 'Complete the array
For i = LBound(Sec_arr) To UBound(Sec_arr)
 Sec_sh.Range(Sec_arr(i)) = First_sh.Range(First_arr(i))
 Next
End Sub
 
Last edited:
Upvote 0
Hi,
I manage to get the code work myself :)


Code:
Sub Step1_CopyRange()
    Dim lr As Long
    
    Application.ScreenUpdating = False
    With Sheets("ad_hoc")        'Source worksheet name
    Set DestSh = Sheets("test")  'Destination worksheet name
    
    'START of confirmation message box'
    response = MsgBox("Run Macro?", vbYesNo)
    If response = vbNo Then
    MsgBox ("Macro Canceled!")
    Exit Sub
    End If
    'END of confirmation message box'
    
         lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
        
  'Ir = last column of x
        .Range(.Cells(17, "B"), .Cells(lr, "B")).Copy DestSh.Cells(4, "A")
        .Range(.Cells(17, "C"), .Cells(lr, "C")).Copy DestSh.Cells(4, "B")
        .Range(.Cells(17, "E"), .Cells(lr, "E")).Copy DestSh.Cells(4, "C")
        .Range(.Cells(17, "H"), .Cells(lr, "H")).Copy DestSh.Cells(4, "D")
        .Range(.Cells(17, "Q"), .Cells(lr, "Q")).Copy DestSh.Cells(4, "E")
        .Range(.Cells(17, "AD"), .Cells(lr, "AD")).Copy DestSh.Cells(4, "F")
        .Range(.Cells(17, "R"), .Cells(lr, "R")).Copy DestSh.Cells(4, "G")
        .Range(.Cells(17, "S"), .Cells(lr, "S")).Copy DestSh.Cells(4, "H")
        .Range(.Cells(17, "T"), .Cells(lr, "T")).Copy DestSh.Cells(4, "I")
        .Range(.Cells(17, "U"), .Cells(lr, "U")).Copy DestSh.Cells(4, "J")
        .Range(.Cells(17, "V"), .Cells(lr, "V")).Copy DestSh.Cells(4, "K")
        .Range(.Cells(17, "W"), .Cells(lr, "W")).Copy DestSh.Cells(4, "L")
        .Range(.Cells(17, "X"), .Cells(lr, "X")).Copy DestSh.Cells(4, "M")
        .Range(.Cells(17, "Y"), .Cells(lr, "Y")).Copy DestSh.Cells(4, "N")
        .Range(.Cells(17, "Z"), .Cells(lr, "Z")).Copy DestSh.Cells(4, "O")
        .Range(.Cells(17, "AA"), .Cells(lr, "AA")).Copy DestSh.Cells(4, "P")
        .Range(.Cells(17, "AB"), .Cells(lr, "AB")).Copy DestSh.Cells(4, "Q")
        .Range(.Cells(17, "AC"), .Cells(lr, "AC")).Copy DestSh.Cells(4, "R")
        
    End With
    Application.ScreenUpdating = True
    
'START MSG'
      MsgBox "Copy Completed!"
      Exit Sub
 'End MSG'
 
End Sub
 
Last edited:
Upvote 0
You can shorten the code to this
Code:
Option Explicit
Sub Copy_columns_Modified()
Rem =====>>This is a simple example
Dim i%, lr%
Dim First_sh As Worksheet
Dim Sec_sh As Worksheet
Dim First_arr(), Sec_arr()


Set First_sh = Sheets("Sheet1") ' Change Sheet1 by the sheet's name of data source
Set Sec_sh = Sheets("Sheet2") ' Change Sheet2  by the sheet's name of data target
lr = First_sh.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row


First_arr = Array("B", "E", "H", "Q") 'Complete the array
Sec_arr = Array("A", "B", "C", "D") 'Complete the array


For i = LBound(Sec_arr) To UBound(Sec_arr)
 First_sh.Cells(17, First_arr(i)).Resize(lr).Copy _
  Sec_sh.Cells(4, Sec_arr(i))
 Next
End Sub
 
Upvote 0
This work great but how to Copy and paste special value?

You can shorten the code to this
Code:
Option Explicit
Sub Copy_columns_Modified()
Rem =====>>This is a simple example
Dim i%, lr%
Dim First_sh As Worksheet
Dim Sec_sh As Worksheet
Dim First_arr(), Sec_arr()


Set First_sh = Sheets("Sheet1") ' Change Sheet1 by the sheet's name of data source
Set Sec_sh = Sheets("Sheet2") ' Change Sheet2  by the sheet's name of data target
lr = First_sh.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row


First_arr = Array("B", "E", "H", "Q") 'Complete the array
Sec_arr = Array("A", "B", "C", "D") 'Complete the array


For i = LBound(Sec_arr) To UBound(Sec_arr)
 First_sh.Cells(17, First_arr(i)).Resize(lr).Copy _
  Sec_sh.Cells(4, Sec_arr(i))
 Next
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,501
Messages
6,114,010
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top