locked
copy specific columns from multiple sheets in separate sheets columns RRS feed

  • Question

  • Hello there,

    I have a workbook with multiple sheets (214 sheets in a workbook) and I need to copy specific columns (same column name in each sheet) from each sheet to new sheets in separate workbook. 

    Like I need to copy column A and Column BL from each sheet and paste it in to a new sheet in column A & B. (please see the below link to access the file). Column BL contain formula and I just want to paste the values not the formula. 

    I used the below macro earlier to get the columns from different sheets to a master sheet but now I am not sure what is should I change to get the data in different sheets.  

    Please advise.

    https://drive.google.com/file/d/1w2WcrgjHg-g3RZB84UF4vorpDOhVpRSS/view?usp=sharing

    Regards, Sara 

    Sub Demo()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim path As String, fileName As String
    Dim lastRowInput As Long, lastRowOutput As Long, rowCntr As Long, lastColumn As Long
    Dim inputWS As Worksheet, outputWS As Worksheet
    
    Set outputWS = ThisWorkbook.Sheets("AverageReturn")
    rowCntr = 1
    
    For i = 1 To ThisWorkbook.Sheets.Count
    If ThisWorkbook.Sheets(i).Name <> "AverageReturn" Then
    Set inputWS = ThisWorkbook.Sheets(i)
    
    
    lastRowInput = inputWS.Cells(Rows.Count, "A").End(xlUp).Row
    lastRowOutput = outputWS.Cells(Rows.Count, "A").End(xlUp).Row
    lastColumn = inputWS.Cells(1, Columns.Count).End(xlToLeft).Column
    
    
    inputWS.Range("BL1:BL" & lastRowInput).Copy outputWS.Cells(1, 1 + i)
    
    
    End If
    
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    End Sub

    • Edited by SaraPhD Thursday, July 30, 2020 3:33 AM correction
    Thursday, July 30, 2020 3:31 AM

Answers

  • Try this. It'll be slow.

    Sub Copy2New()
        Dim strPath As String
        Dim strFile As String
        Dim wsh As Worksheet
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        strPath = ActiveWorkbook.path
        If Right(strPath, 1) <> "\" Then
            strPath = strPath & "\"
        End If
        strFile = "New.xlsm"
        ActiveWorkbook.SaveAs strPath & strFile
        For Each wsh In Worksheets
            If wsh.Name <> "AverageReturn" Then
                wsh.Range("BL:BL").Value = wsh.Range("BL:BL").Value
                wsh.Range("B1:BK1").EntireColumn.Delete
            End If
        Next wsh
        Application.EnableEvents = True
        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (https://www.eileenslounge.com)

    • Marked as answer by SaraPhD Tuesday, August 4, 2020 9:35 AM
    Thursday, July 30, 2020 9:57 AM

All replies

  • Try this. It'll be slow.

    Sub Copy2New()
        Dim strPath As String
        Dim strFile As String
        Dim wsh As Worksheet
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        strPath = ActiveWorkbook.path
        If Right(strPath, 1) <> "\" Then
            strPath = strPath & "\"
        End If
        strFile = "New.xlsm"
        ActiveWorkbook.SaveAs strPath & strFile
        For Each wsh In Worksheets
            If wsh.Name <> "AverageReturn" Then
                wsh.Range("BL:BL").Value = wsh.Range("BL:BL").Value
                wsh.Range("B1:BK1").EntireColumn.Delete
            End If
        Next wsh
        Application.EnableEvents = True
        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (https://www.eileenslounge.com)

    • Marked as answer by SaraPhD Tuesday, August 4, 2020 9:35 AM
    Thursday, July 30, 2020 9:57 AM
  • Thanks heaps for your help, much appreciated.

    Regards, Sara

    Tuesday, August 4, 2020 9:37 AM