Sub CaptnApo()
'The .Columns.Count+1 and then the '37' in the array is so i can reference a blank column 'outside' the real CurrentRegion.. hence allowing for the blank column in the output.
Dim wsDump As Worksheet, wsOut As Worksheet 'Give Abbreviation Methods, Properties of Object Worksheet through .dot
Set wsDump = ThisWorkbook.Worksheets("Dump"): Set wsOut = ThisWorkbook.Worksheets("Output")
Dim x
With wsDump.Range("A1").CurrentRegion
x = .Offset(1).Resize(.Rows.Count - 1, .Columns.Count + 1).Value 'ArrayIn from Row 2 * 1 column
wsOut.Cells(2, 1).Resize(UBound(x), 12) = Application.Index(x, Evaluate("row(1:" & UBound(x) + 1 & ")"), Array(1, 6, 4, 13, 35, 36, 37, 19, 28, 15, 2, 3))
End With
End Sub
'Option Explicit'This must be commented out for simplified Code
Sub CopyColumnsAlanSHimpfGlified()
Dim arrin() As Variant: Let arrin() = Dump.Range("A2:AK" & Dump.Cells(Rows.Count, 1).End(xlUp).Row).Value
Let arrin(1, 37) = "Cleared"
Dim c() As Variant: Let c() = Array("1", "6", "4", "13", "35", "36", "37", "19", "28", "15", "2", "3"): Let c() = Application.WorksheetFunction.Transpose(c())
For iii = LBound(arrin(), 1) To UBound(arrin(), 1)
Let strRows = strRows & " " & iii
Next iii
Dim outArr() As Variant: outArr() = Application.WorksheetFunction.Transpose(Application.Index(arrin(), Split(Trim(strRows), " "), c()))
Output.Range("A2").Resize(UBound(outArr(), 1), UBound(outArr(), 2)) = outArr()
End Sub
'
'
'
'
'
'
'
Sub CopyColumnsAlan()
' 1) Get Initial Data
Dim wsDump As Worksheet, wsOut As Worksheet 'Give Abbreviation Methods, Properties of Object Worksheet through .dot
Set wsDump = ThisWorkbook.Worksheets("Dump"): Set wsOut = ThisWorkbook.Worksheets("Output")
Dim lr As Long, lc As Long 'Variable for, last Row, last Column of sheet1. Assume our File for Input has a reasonably well defined end. Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster.
Let lc = 36: Let lr = wsDump.Cells.Find(What:="*", After:=wsDump.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), searching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method that finds last row in sheet rather than row for last entry in particular cell. Better to use that here as we are not sure which columns are full
Let lc = lc + 1 'Include an extra column, assume that column is empty
Dim arrin() As Variant: Let arrin() = wsDump.Range(wsDump.Cells(2, 1), wsDump.Cells(lr, lc)).Value 'Allowed VBA One Liner - An Array of variants may be set to a collection of Range values. The Range object works as to return a collection of (Variants initially) of various types. So Initially must see an Array of Variant types for compatability
Let arrin(1, lc) = "Cleared" 'Extra heading in last "Column" in Array
' 2) We could include a part here to make the output be made dynamic to extract the column based on the column heading
' - this would involve an alternative way to get at c()
' 3 )obtain an Array of indicies for required output columns and all "row" indices from array arrin()
Dim c() As Variant: Let c() = Array("1", "6", "4", "13", "35", "36", "" & lc & "", "19", "28", "15", "2", "3"): Let c() = Application.WorksheetFunction.Transpose(c())
Dim iii As Long, strRows As String 'Loop Bound (Count) Variable and tempoary sting for row indicies
For iii = LBound(arrin(), 1) To UBound(arrin(), 1) 'Lower Bound by me is header
Let strRows = strRows & " " & iii 'Concatenating valid "row" indicies
Next iii
Let strRows = Trim(strRows) 'trim off first space
Dim r() As String: Let r() = Split(strRows, " ")
Dim outArr() As Variant 'I believe here the Index is working in some "vector" type form here. VBA "works" as follows here:
Let outArr() = Application.Index(arrin(), r(), c()) 'It takes in turn each of the indicies in rws()
' 'and for each of these it steps through the indicies in clms(). It returns then effectively a "column" of values.
' ' These values are then the entities in the main Array arrin() given by those co-ordinates. In our case then, we initially put into the new Array y(), a column which contains the first data row.
Let outArr() = Application.WorksheetFunction.Transpose(outArr()) '...As this process is then repeated for all the indicies given in rws() we effectively have an Array y() of our required output rows , but transposed. ( so we transpose it back to the correct orientation! )
' 3 ) Output Array with required Columns, and Rows out to Output Sheet
Let wsOut.Range("A2").Resize(UBound(outArr(), 1), UBound(outArr(), 2)) = outArr() 'Simple neat allowed VBA one liner to assign values in an Array to a spreadsheet Range: Resize top left of output range to size of outout array and make it = th that Array
End Sub
Sub copycolumns_Jacc()
Dim LrDump As Long
Dim LrOutput As Long
Dim i As Long
' The next two lines could be commented out: Jacc; What I did was to change the programming name of the worksheet manually.
'You can do that by selecting a worksheet to the left in the Project Explorer in the VBA editor, then in the properties window below (hit F4 if it's not displayed) you can see the programming name (or object name) at the top and simply change it.
Dim Dump As Worksheet, Output As Worksheet 'Give Abbreviation Methods, Properties of Object Worksheet through .dot
Set Dump = ThisWorkbook.Worksheets("Dump"): Set Output = ThisWorkbook.Worksheets("Output")
LrDump = Dump.Cells(Rows.Count, 1).End(xlUp).Row
Intersect(Output.Cells.Columns(1), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(1), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(2), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(6), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(3), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(4), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(4), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(13), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(5), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(35), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(6), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(36), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(8), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(19), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(9), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(28), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(10), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(15), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(11), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(10), Dump.Cells.Rows("1:" & LrDump)).Value
Intersect(Output.Cells.Columns(12), Output.Cells.Rows("1:" & LrDump)).Value = Intersect(Dump.Cells.Columns(11), Dump.Cells.Rows("1:" & LrDump)).Value
Output.Columns.AutoFit
Output.Activate
Output.Range("A1").Select
End Sub
LinkBack URL
About LinkBacks
Jayant shettigar 
Register To Reply
<----- If you were helped by my posts you can say "Thank you" by clicking the star symbol down to the left 
Originally Posted by Jacc
Hi ! Try this demonstration !
Re: Copy columns from sheet 1 to sheet 2 using column heading as criteria using VBA
Bookmarks