Copy a cell from all worksheets in another sheet-CodePudding

I would like to copy a Cell from all worksheet but "Data" Worksheet on column C of "Data Worksheet". The following code is not working properly, always blank value. The value I would like to copy is placed on E16 Cell.

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Data" Then
        x = x   1
        Sheets("Data").Range("B1").Offset(x) = Worksheets(ws.Name).Cells(4, 16).Value
    End If
Next ws

CodePudding user response：

Try it that Way, without coping every value by it's own:

Sub m()
vartemp2 = Range("A1:A2")
vartemp2 = WorksheetFunction.Transpose(vartemp2)
    Dim varTemp As Variant
    For Each ws In Worksheets
        If ws.Name <> "Data" Then
            If i = 0 Then
                ReDim varTemp(1 To 1, 1 To 1)
                i = 1
            Else
                varTemp = WorksheetFunction.Transpose(varTemp)
                ReDim Preserve varTemp(1 To UBound(varTemp)   1)
                varTemp = WorksheetFunction.Transpose(varTemp)
            End If
            varTemp(UBound(varTemp), 1) = ws.Cells(16, 5).Value
        End If
    Next ws
    
    With Worksheets("Data")
        .Range(.Cells(1, 2), .Cells(UBound(varTemp), 2)).Value = varTemp
    End With
End Sub

BTW: On your code, 4 is column D not E. Columns start with 1 on counting and the defintion is Cells(RowNumber, ColumnNumber) :)

CodePudding user response：

Copy Single Cell's Value From All Other Worksheets

Compact

Sub CopySingleCellValuesCompact()

    Dim wb As Workbook: Set wb = ActiveWorkbook ' possibly use 'ThisWorkbook'
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Data")
    Dim dCell As Range: Set dCell = dws.Range("B1")
    
    Dim sws As Worksheet
    Dim sCell As Range
    
    For Each sws In wb.Worksheets
        If Not sws Is dws Then
            Set sCell = ws.Range("E16")
            Set dCell = dCell.Offset(1)
            dCell.Value = sCell.Value
        End If
    Next sws

End Sub

Argumented

Now, to get rid of the magic numbers, you could create a method...

Sub CopySingleCellValues( _
        ByVal wb As Workbook, _
        ByVal DestinationWorksheetName As String, _
        ByVal DestinationLastCellAddress As String, _
        ByVal SourceCellAddress As String)

    Dim dws As Worksheet: Set dws = wb.Worksheets(DestinationWorksheetName)
    Dim dCell As Range: Set dCell = dws.Range(DestinationLastCellAddress)
    
    Dim sws As Worksheet
    Dim sCell As Range
    
    For Each sws In wb.Worksheets
        If Not sws Is dws Then
            Set sCell = ws.Range(SourceCellAddress)
            Set dCell = dCell.Offset(1)
            dCell.Value = sCell.Value
        End If
    Next sws

End Sub

Usage

... and in your code, use it in the following way:

Sub MyCode()
    
    Dim wb As Workbook: Set wb = ActiveWorkbook ' possibly use 'ThisWorkbook'
    CopySingleCellValues wb, "Data", "B1", "E16"

End Sub

... and keep your code clean as a whistle.
It reads something like: in the given workbook, from all worksheets except worksheet Data, copy the value from cell E16 to worksheet Data, one below the other, starting with the first cell below B1.