Copy selected column in range to another sheet

[motilulla]

Using Excel 2010
Hello,

I need VBA which can have column with range selection via input box and then copy columns in to another sheet

I have sheet (data) from this sheet I want to copy (3 columns) column C from range C5:C45, column F from range F5:F45, column J from range J5:J45 in to sheet (copy columns).

For example VBA give an option to select column if I select C5, F5 and J5, it should copy 3 columns with range from 5 to 45 as shown in the example below.

data sheet...

Copy Columns.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3
4
5	S.N	Group	n1	n2	n3	n4	n5	n6	n7	n8	n9	n10
6	1	1	27	30	32	29	38	26	36	11	13	44
7	2	2	4	42	38	29	26	43	31	7	47	39
8	3	3	44	9	35	6	17	33	34	38	29	33
9	4	4	46	48	27	28	38	47	28	11	29	44
10	5	1	36	9	34	36	38	16	12	31	42	4
11	6	2	34	47	7	5	10	11	27	40	10	22
12	7	3	43	40	50	30	38	2	46	1	4	28
13	8	4	26	31	8	44	2	26	5	14	17	31
14	9	1	3	12	26	8	18	13	2	31	37	46
15	10	2	38	23	26	1	9	48	3	15	30	14
16	11	3	9	44	28	16	3	33	3	45	43	6
17	12	4	32	41	11	31	1	47	3	49	39	33
18	13	1	13	35	11	17	39	30	18	24	12	27
19	14	2	2	46	34	26	26	45	19	44	50	14
20	15	3	23	30	9	49	30	30	7	19	16	44
21	16	4	22	35	38	20	27	24	40	20	47	46
22	17	1	16	50	46	37	21	45	11	40	50	17
23	18	2	5	1	48	25	50	40	23	42	34	29
24	19	3	16	33	36	29	20	46	20	44	33	25
25	20	4	24	23	13	32	48	15	14	2	46	18
26	21	1	19	46	4	9	16	37	4	13	38	44
27	22	2	26	22	33	34	31	42	2	4	6	4
28	23	3	34	21	17	29	44	23	7	49	10	13
29	24	4	35	5	14	4	10	30	44	12	29	42
30	25	1	27	50	43	28	1	38	33	5	12	40
31	26	2	20	19	32	38	43	40	17	24	36	45
32	27	3	45	42	4	4	32	18	19	29	33	14
33	28	4	43	45	24	38	7	44	45	42	17	20
34	29	1	45	10	13	50	36	45	34	29	32	41
35	30	2	38	5	23	49	50	22	25	12	23	8
36	31	3	22	36	17	25	12	10	27	39	40	46
37	32	4
38	33	1
39	34	2
40	35	3
41	36	4
42	37	1
43	38	2
44	39	3
45	40	4
Data

Copy Here.....

Copy Columns.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3
4
5	S.N	Group	n1	n4	n8
6	1	1	27	29	11
7	2	2	4	29	7
8	3	3	44	6	38
9	4	4	46	28	11
10	5	1	36	36	31
11	6	2	34	5	40
12	7	3	43	30	1
13	8	4	26	44	14
14	9	1	3	8	31
15	10	2	38	1	15
16	11	3	9	16	45
17	12	4	32	31	49
18	13	1	13	17	24
19	14	2	2	26	44
20	15	3	23	49	19
21	16	4	22	20	20
22	17	1	16	37	40
23	18	2	5	25	42
24	19	3	16	29	44
25	20	4	24	32	2
26	21	1	19	9	13
27	22	2	26	34	4
28	23	3	34	29	49
29	24	4	35	4	12
30	25	1	27	28	5
31	26	2	20	38	24
32	27	3	45	4	29
33	28	4	43	38	42
34	29	1	45	50	29
35	30	2	38	49	12
36	31	3	22	25	39
37	32	4
38	33	1
39	34	2
40	35	3
41	36	4
42	37	1
43	38	2
44	39	3
45	40	4
Copy Column

Regards,
Moti

 

[motilulla]

Why have you got multiple header rows in the 'data' worksheet?

Hello HighAndWilder, you can change any text or numbers when you select in data sheet C5, F5, G5 or any it should copy column below the row5 to 45 but it is copying from row1 I guess code need to be adjusted. I am not sure but may be it is due to CurrentRegion?

Kind regards,
Moti

 

[HighAndWilder]

Hello HighAndWilder, you can change any text or numbers when you select in data sheet C5, F5, G5 or any it should copy column below the row5 to 45 but it is copying from row1 I guess code need to be adjusted. I am not sure but may be it is due to CurrentRegion?

Kind regards,
Moti

When you select the column headings for the columns that you want to be copied, which row are you selecting these from? You should be selecting them from row 5 of the
'data' worksheet.

 

[motilulla]

When you select the column headings for the columns that you want to be copied, which row are you selecting these from? You should be selecting them from row 5 of the
'data' worksheet.

Yes it is correct

 

[HighAndWilder]

When you select the column headings for the columns that you want to be copied, which row are you selecting these from? You should be selecting them from row 5 of the
'data' worksheet.

Re: CurrentRegion. - Because my data did not include anything above row 5, and yours did, it did copy from row 1.

I'll change it and re post.

 

[HighAndWilder]

Re: CurrentRegion. - Because my data did not include anything above row 5, and yours did, it did copy from row 1.

I'll change it and re post.

Public Sub subCopyColumns()
Dim rng As Range
Dim r As Range
Dim t As String
Dim rngToCopy As Range
Dim rngDestination As Range
Dim rngData As Range
Dim Ws As Worksheet
Dim lngLastRow As Long

  ActiveWorkbook.Save
    
  Set Ws = Worksheets("data")
    
  On Error Resume Next
    
  Set rng = Application.InputBox(Prompt:="Select headings of columns to copy.", Type:=8)
  
  On Error GoTo 0
  
  If rng Is Nothing Then
    Exit Sub
  End If
  
  With Ws
    lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set rngData = .Range("A5").Resize(lngLastRow - 4, 12)
  End With
    
  For Each r In rng.Cells
    If Not rngToCopy Is Nothing Then
      Set rngToCopy = Union(rngToCopy, rngData.Columns(r.Column).Resize(41, r.Columns.Count))
    Else
      Set rngToCopy = rngData.Columns(r.Column).Resize(41, r.Columns.Count)
    End If
  Next r
    
  With Worksheets("copy columns")
    
    .Activate
    
    Set rngDestination = .Range("C5")
  
    For Each rng In rngToCopy.Areas
              
      rng.Copy
      
      rngDestination.PasteSpecial xlPasteValues
      
      Application.CutCopyMode = False
  
      Set rngDestination = rngDestination.Offset(, rng.Columns.Count)
      
    Next rng
  
    .Range("C5").Select
  
  End With
  
  ActiveWorkbook.Save
  
End Sub

 

[motilulla]

Public Sub subCopyColumns()
Dim rng As Range
Dim r As Range
Dim t As String
Dim rngToCopy As Range
Dim rngDestination As Range
Dim rngData As Range
Dim Ws As Worksheet
Dim lngLastRow As Long

  ActiveWorkbook.Save
   
  Set Ws = Worksheets("data")
   
  On Error Resume Next
   
  Set rng = Application.InputBox(Prompt:="Select headings of columns to copy.", Type:=8)
 
  On Error GoTo 0
 
  If rng Is Nothing Then
    Exit Sub
  End If
 
  With Ws
    lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set rngData = .Range("A5").Resize(lngLastRow - 4, 12)
  End With
   
  For Each r In rng.Cells
    If Not rngToCopy Is Nothing Then
      Set rngToCopy = Union(rngToCopy, rngData.Columns(r.Column).Resize(41, r.Columns.Count))
    Else
      Set rngToCopy = rngData.Columns(r.Column).Resize(41, r.Columns.Count)
    End If
  Next r
   
  With Worksheets("copy columns")
   
    .Activate
   
    Set rngDestination = .Range("C5")
 
    For Each rng In rngToCopy.Areas
             
      rng.Copy
     
      rngDestination.PasteSpecial xlPasteValues
     
      Application.CutCopyMode = False
 
      Set rngDestination = rngDestination.Offset(, rng.Columns.Count)
     
    Next rng
 
    .Range("C5").Select
 
  End With
 
  ActiveWorkbook.Save
 
End Sub

Amazing HighAndWilder, absolutely correct data is coping perfect within the range and with values only 100% solved!

I appreciate your kind help. Have a great weekend. Good Luck.

Kind regards,
Moti