CODEWITHSUNDEEP
excelvba
tpandas
tpandas

Reputation: 61

How to take certain cell values from multiple sheets

I have a sheet I'm trying to have populate names and some cell values from the following sheets.

I'm trying to copy the values from the specified cells, dump them into my sheet, and move to the next sheet.

Here is a snapshot of the sheet I'm trying to build, and I've written in the cell location of each value I'm looking for.
enter image description here

The script would take the values in those specified cells on each following sheets and then move to the next.

Sub EfficiencyReport001()
    
    Dim ws As Worksheet, rep As Worksheet, LastRow As Double
    With ThisWorkbook
        For n = 1 To Sheets.Count
            Set ws = Worksheets(n)
            Set rep = Worksheets("001 Efficiency Report")
            LastRow = rep.Range("A3", rep.Range("A3").End(xlDown)).Rows.Count
            If IsNumeric(ws.Name) Then
                If rep.Range("A3") = "" Then
                    ws.Range("E20", ws.Range("E20").End(xlDown)).Copy _
                    Destination:=rep.Range("A3")
                Else:
                    ws.Range("E20", ws.Range("E20").End(xlDown)).Copy _
                    Destination:=rep.Range("A" & LastRow)
                End If
            End If
        Next n
    End With
    
End Sub

Upvotes: 0

Views: 96

Answers (1)

urdearboy
urdearboy

Reputation: 14580

I think you want something like this.

  1. Loop through all sheets (except the Rep sheet)
  2. Copy values from E20 do Last Cell on your current loop sheet
  3. Paste the values on Rep sheet in the first available cell in Column A
Sub Shelter_In_Place()

Dim rep As Worksheet: Set rep = ThisWorkbook.Sheets("001 Efficiency Report")
Dim ws As Worksheet

Dim lr As Long

For Each ws In Worksheets
    If ws.Name <> rep.Name Then
        lr = rep.Range("A" & ws.Rows.Count).End(xlUp).Offset(1).Row
        ws.Range("E20:E" & ws.Range("E" & ws.Rows.Count).End(xlUp).Row).Copy
        rep.Range("A" & lr).PasteSpecial xlPasteValues
    End If
Next ws

End Sub

If you just want to grab the 4 individual cells from each sheet then you can use

Sub Shelter_In_Place()

Dim rep As Worksheet: Set rep = ThisWorkbook.Sheets("001 Efficiency Report")
Dim ws As Worksheet

Dim lr As Long

For Each ws In Worksheets
    If ws.Name <> rep.Name Then

        lr = rep.Range("A" & ws.Rows.Count).End(xlUp).Offset(1).Row

        rep.Range("A" & lr).Value = ws.Range("E20").Value
        rep.Range("B" & lr).Value = ws.Range("AD65").Value
        rep.Range("C" & lr).Value = ws.Range("AF65").Value
        rep.Range("D" & lr).Value = ws.Range("AH65").Value
        rep.Range("E" & lr).Value = ws.Range("AJ65").Value

    End If
Next ws

End Sub

Upvotes: 1

Related Questions