Forum Discussion

Marina Alvarado's avatar
Marina Alvarado
Copper Contributor
Apr 09, 2018

Pull values from other sheets to a summary sheet in workbook

Hi I need help with pulling certain cells from purchase orders to a summary sheet on the first sheet of the workbook. There are new purchase order sheets that will continue to be added so need it to loop thru the whole workbook. This is what I have right now.  Been looking at different methods I have found but figure I should just ask some experts :) Thanks in advance.

 

Sub CopytoSummary()

Dim wks As Worksheets
Dim CopyRng As Range
Dim DestSht As Sheet1
Dim Last As Long

'For Each wks In ActiveWorkbook.Worksheets
    If wks.Name <> DestSht Then
'Select source range
    Set CopyRng = (Range("A16:A30"),Cells(4,"K"),Cells(8,"K"),Cells(30,"J"))
'Copy to Summary
    CopyRng.Copy
    With DestSht.Cells(1, Last + 1)
            .PasteSpecial 8    ' Column width
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With
    
    End If
    
End Sub

 

Macros & VBA
Need Help
  • Tomasz Kocur's avatar
    Tomasz Kocur
    Brass Contributor
    Apr 10, 2018

    Hi Marina

    It is quite difficult to create a macro without seeing the source but I can be guessing what you are looking for, please see below

     

    Option Explicit

    Sub CopytoSummary()

    Dim wks As Worksheet
    Dim CopyRng As Range
    Dim DestSht As Worksheet
    Dim LastFreeColumn As Long
    Dim DestRowNo As Byte
    Dim c As Range

     

    'below "with" speed up the macro
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

     

    'setting the destination as sheet1 you can use sheet name instead
    Set DestSht = Sheet1

     

    'looping through each wks in workbook
    For Each wks In ActiveWorkbook.Worksheets
       
        'if wks is different than destination will go through
        If wks.Name <> DestSht.Name Then
            Set wks = wks
           
            'Select source range
            With wks
                Set CopyRng = .Range("A16:A30, K4, K8, J30")
            End With
           
           
            With DestSht
               
                'setting the last free destination column
                LastFreeColumn = .Cells(1, 1600).End(xlToLeft).Column + 1
                DestRowNo = 1
               
                'Copy eacjh cell to Summary
                For Each c In CopyRng
                    c.Copy .Cells(DestRowNo, LastFreeColumn)
                    DestRowNo = DestRowNo + 1
                Next c
           
            'column width
            .Columns(LastFreeColumn).ColumnWidth = 8
            End With
        End If

    Next wks

     

    'set the application back to normal
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

     

    End Sub

Resources