Results 1 to 4 of 4
  1. #1
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post

    Need further modification in the below code.

    Hi ExpertsI have the below code, which works perfectly fine. I need to add functionality to it. In the current scenario. I paste the RAW data from the master sheet which consist many tabs/sheets. I copy the RAW tab/sheet from the master sheet and paste it in the RAW tab of the macro file and run the below code and the output gets saved in the 2nd tab in the macro sheet which I have named Result. Is it possible to tweak the code which works as follow? I will open the macro first and then open the master sheet. Once I ran the code it go to the RAW tab of the master sheet and move specific columns from in and save it in a new excel file.Please let me know if you are unclear by the modification.
    Code:
    Sub CopyColumnByTitle()
    
       Dim SearchCols(14) As String
       Dim i As Integer
     
       Application.ScreenUpdating = False
       Sheets("Result").Cells.ClearContents // Output Sheet
       ActiveWorkbook.Worksheets("Raw").Activate  // Input sheet
    
       SearchCols(0) = "Facility_name"
       SearchCols(1) = "operating_company_name"
       SearchCols(2) = "Address"
       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"
    
    'continue with all the column names
    'Find "Entity" in Row 1
    
       With Sheets("Raw").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("Result").Range("A1").Value = "" Then
                  pasteCol = 1            
                Else  
                  pasteCol = Sheets("Result").Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                End If 
    
                .Columns(t.Column).EntireColumn.Copy _
                   Destination:=Sheets("Result").Cells(1, pasteCol) 
           
                Else 
                  MsgBox SearchCols(i) & " Not Found"
                End If
    
            Next
    
        End With
    
        Application.ScreenUpdating = True
    
    End Sub
    Regards,JD
    Last edited by RetiredGeek; 2015-04-16 at 14:18. Reason: Cleaned up code from single line!

  2. #2
    3 Star Lounger Supershoe's Avatar
    Join Date
    Apr 2014
    Location
    Austin, TX
    Posts
    252
    Thanks
    1
    Thanked 36 Times in 34 Posts
    attach file with code properly presented.
    Don Guillett
    Excel Developer
    dguillett @gmail.com

  3. #3
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi Don

    Please find the code file attached with the mail.

    Regards,
    JD
    Attached Files Attached Files

  4. #4
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi Don

    I somehow managed to get this fixed. Thanks for looking into this query.

    Regards,
    JD

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •