• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Amendment in the code.

J

Jagdev Singh

Active Member
Hi Experts
I have the below code which moves list of columns from one sheet to another while considering the header name. Is it possible instead of mentioning column header name in an array the code ask me to select the column number say A, B, and C etc… and use them as an input and move their respective data to the new sheet.
Code: 
Sub CopyColumnByTitle()
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets("Risk Score Result").Activate
Dim ws As Worksheet
Dim SearchCols(14) As String
SearchCols(0) = "Facility_name"
SearchCols(3) = "Country"
SearchCols(4) = "TSI"
SearchCols(5) = "Currency"
SearchCols(6) = "Cyclone"
SearchCols(7) = "Drought"
SearchCols(8) = "Earthquake"
SearchCols(9) = "Fire"
SearchCols(10) = "Flood"
SearchCols(11) = "Landslide"
SearchCols(12) = "Lightning"
SearchCols(13) = "Storm Surge"
SearchCols(14) = "Tsunami"
Dim i As Integer
'Find "Entity" in Row 1
With Sheets("Result").Rows(1)
    For i = LBound(SearchCols) To UBound(SearchCols)
        Set t = .Find(SearchCols(i), LookAt:=xlPart)
        'If found, copy the column to Sheet 2, Column A
      'If not found, present a message
    
        If Not t Is Nothing Then
            If Sheets("Temp").Range("A1").Value = "" Then
                pasteCol = 1
            Else
                pasteCol = Sheets("Temp").Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
            End If
        
            .Columns(t.Column).EntireColumn.Copy _
            Destination:=Sheets("Temp").Cells(1, pasteCol)
        Else
            MsgBox SearchCols(i) & " Not Found"
        End If
    Next
End With
End Sub
Please let me know if I am unclear with your doubts.
Regards,
JD
 
Try this:
Code: 
Sub CopyColumnByTitle()

Dim ws As Worksheet
Dim userInput As Long
Dim SearchCols(100) As String
Dim i As Integer
Dim t As Range
Dim pasteCol As Long

userInput = 1
'Query user for columns
Do
    SearchCols(userInput) = InputBox("Please enter a column to copy (1 column)", "Copy Column")
    userInput = userInput + 1
Loop Until MsgBox("Do you want to add another?", vbYesNo + vbDefaultButton1, "Add more") <> vbYes
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets("Risk Score Result").Activate

'Find "Entity" in Row 1
With Sheets("Result").Rows(1)
    For i = 1 To userInput - 1
        Set t = .Cells(1, SearchCols(i))
        'If found, copy the column to Sheet 2, Column A
     'If not found, present a message
   
        If Not t Is Nothing Then
            If Sheets("Temp").Range("A1").Value = "" Then
                pasteCol = 1
            Else
                pasteCol = Sheets("Temp").Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
            End If
       
            .Columns(t.Column).EntireColumn.Copy _
            Destination:=Sheets("Temp").Cells(1, pasteCol)
        Else
            MsgBox SearchCols(i) & " Not Found"
        End If
    Next
End With
Application.ScreenUpdating = True
End Sub
 
Hi Luke

The code looks fine. I saw somewhere on Chandoo a code which allow user to click on the column name and it gets add in the inputbox. There will be multiple column selection everytime in my requirement adding single column at a time is bit hectic.

The code I saw was like click the columns you want to select. The user selects multiple column of its wish in one go and click ok. The rest of the operation works in the same way.

Please let me know if this is possible.

Regards,
JD
 
If you're already selecting all the columns, why not just copy them normally? XL supports multi-selection copy/paste. But very well...
Code: 
Sub CopyColumnByTitle()

Dim ws As Worksheet
Dim colCells As Range
Dim userSel As Range
Dim i As Integer
Dim t As Range
Dim pasteCol As Long

'ASSUMPTION
'User has selected which columns to copy
Set userSel = Intersect(Selection, Range("1:1"))

Application.ScreenUpdating = False
ActiveWorkbook.Worksheets("Risk Score Result").Activate

'Find "Entity" in Row 1
With Sheets("Result").Rows(1)
    For Each colCells In userSel
        Set t = colCells
        'If found, copy the column to Sheet 2, Column A
    'If not found, present a message
        If Not t Is Nothing Then
            If Sheets("Temp").Range("A1").Value = "" Then
                pasteCol = 1
            Else
                pasteCol = Sheets("Temp").Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
            End If
      
            .Columns(t.Column).EntireColumn.Copy _
            Destination:=Sheets("Temp").Cells(1, pasteCol)
        Else
            MsgBox SearchCols(i) & " Not Found"
        End If
    Next colCells
End With
Application.ScreenUpdating = True
End Sub
 
Last edited:
Hi Luke

The above code is not asking me to select any column and also throwing error at the following line of code.

For Each colCells In userSel

424 object required.

Regards,
JD
 
Select the columns before running the code. That is why the first bit of code says:
Code: 
'ASSUMPTION
'User has selected which columns to copy
 
Hi Luke

Could you please help me to amend the above code.

I want to paste the data in the destination sheet from cell B5. i.e sheet - "temp".

I do not want the header only the data from the source sheet to be paste..

Regards,
JD
 
Try this:
Code: 
Sub CopyColumnByTitle()

Dim ws As Worksheet
Dim colCells As Range
Dim userSel As Range
Dim i As Integer
Dim t As Range
Dim pasteCol As Long
Dim lastRow As Long

'ASSUMPTION
'User has selected which columns to copy
Set userSel = Intersect(Selection, Range("1:1"))
lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

Application.ScreenUpdating = False
ActiveWorkbook.Worksheets("Risk Score Result").Activate

'Find "Entity" in Row 1
With Sheets("Result").Rows(1)
    For Each colCells In userSel
        Set t = colCells
        'If found, copy the column to Sheet 2, B5

          If Sheets("Temp").Range("B5").Value = "" Then
              pasteCol = 2
          Else
              pasteCol = Sheets("Temp").Cells(5, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
          End If
   'Copy from row 2 to end of data, paste in row 5
          .Range(.Cells(2, t.Column), .Cells(lastRow, t.Column)).Copy _
          Destination:=Sheets("Temp").Cells(5, pasteCol)
    Next colCells
End With
Application.ScreenUpdating = True
End Sub
 
You must log in or register to reply here.
Back
Top