Macro for copy and paste nonempty cells

[denton]

Hi,

do you think you can help me?
In sheet2 I have in columns C and D some numbers. but numbers arent in all cells, eg C1 is numbered,C2 empty,C3-C6 numbered,C7 empty,C8 numbered etc. The same for column D.

I need to make some macro which will copy only cells with numbers from column C to sheet1 (=will copy cells C1,C3-C6,C8 from sheet2), but...in sheet1 i have table 40x4 cells (C1:F40). Imagine that macro will find cca 100 numbered cells from columnd C in sheet2 - i need to put these numbers to table C1:F40 in sheet1 ->first 40 numbers will be in C1:C40, the 41st will be in D1 and so on,81 st in E1. It is easy to make it handy, but I'd like to make some macro.
The same way for column D in sheet2 -> copy only numbered cells from Sheet2 to Sheet1,column A

Would be great if you can help me.

 

[denton]

You said "In sheet2 I have in columns C and D some numbers". Are those numbers constants or the result of formulas? My code assumes they are constants. If they are the result of formulas try changing:

Set Rng = Sh2.Columns("C:C").SpecialCells(xlCellTypeConstants, 1)

to:

Set Rng = Sh2.Columns("C:C").SpecialCells(xlCellTypeFormulas, 1)

Much better!
but i wanted to copy only numbered cells (not zero). now the numbers are copied in sheet1 very chaotic and including zeroes
And how can i make the same way with column D ? Numbers from D in sheet2 copy to A in sheet1. You are very kind, thank you!

 

[Andrew Poulsom]

Try:

Sub Test() 
    Dim Sh1 As Worksheet 
    Dim Sh2 As Worksheet 
    Dim Rng As Range 
    Dim r As Integer 
    Dim c As Integer 
    Dim Cell As Range 
    Set Sh1 = Worksheets("Sheet1") 
    Set Sh2 = Worksheets("Sheet2") 
    Set Rng = Sh2.Columns("C:C").SpecialCells(xlCellTypeFormulas, 1) 
    r = 1 
    c = 3 
    For Each Cell In Rng.Cells 
        If r > 40 Then 
            r = 1 
            c = c + 1 
        End If 
        If Cell.Value <> 0 Then
            Sh1.Cells(r, c).Value = Cell.Value 
            r = r + 1 
        End If
    Next Cell 
    Set Rng = Sh2.Columns("D:D").SpecialCells(xlCellTypeFormulas, 1) 
    r = 1 
    c = 1 
    For Each Cell In Rng.Cells 
        If Cell.Value <> 0 Then
            Sh1.Cells(r, c).Value = Cell.Value 
            r = r + 1 
        End If
    Next Cell 
End Sub

 

[denton]

Try:

Sub Test() 
    Dim Sh1 As Worksheet 
    Dim Sh2 As Worksheet 
    Dim Rng As Range 
    Dim r As Integer 
    Dim c As Integer 
    Dim Cell As Range 
    Set Sh1 = Worksheets("Sheet1") 
    Set Sh2 = Worksheets("Sheet2") 
    Set Rng = Sh2.Columns("C:C").SpecialCells(xlCellTypeFormulas, 1) 
    r = 1 
    c = 3 
    For Each Cell In Rng.Cells 
        If r > 40 Then 
            r = 1 
            c = c + 1 
        End If 
        If Cell.Value <> 0 Then
            Sh1.Cells(r, c).Value = Cell.Value 
            r = r + 1 
        End If
    Next Cell 
    Set Rng = Sh2.Columns("D:D").SpecialCells(xlCellTypeFormulas, 1) 
    r = 1 
    c = 1 
    For Each Cell In Rng.Cells 
        If Cell.Value <> 0 Then
            Sh1.Cells(r, c).Value = Cell.Value 
            r = r + 1 
        End If
    Next Cell 
End Sub

Absolutely perfect! Thank you very much!!!

 

[denton]

Try:

Sub Test() 
    Dim Sh1 As Worksheet 
    Dim Sh2 As Worksheet 
    Dim Rng As Range 
    Dim r As Integer 
    Dim c As Integer 
    Dim Cell As Range 
    Set Sh1 = Worksheets("Sheet1") 
    Set Sh2 = Worksheets("Sheet2") 
    Set Rng = Sh2.Columns("C:C").SpecialCells(xlCellTypeFormulas, 1) 
    r = 1 
    c = 3 
    For Each Cell In Rng.Cells 
        If r > 40 Then 
            r = 1 
            c = c + 1 
        End If 
        If Cell.Value <> 0 Then
            Sh1.Cells(r, c).Value = Cell.Value 
            r = r + 1 
        End If
    Next Cell 
    Set Rng = Sh2.Columns("D:D").SpecialCells(xlCellTypeFormulas, 1) 
    r = 1 
    c = 1 
    For Each Cell In Rng.Cells 
        If Cell.Value <> 0 Then
            Sh1.Cells(r, c).Value = Cell.Value 
            r = r + 1 
        End If
    Next Cell 
End Sub

Hi again,

it works superb, but i found one problem. Unless it found non-zero cells in column C, this makro stops with warning message "No cells found" and doesnt continue with searching non-zero cells in column D. It means, there should not be non zero cells in C, but may be in D and I need to pick those in D column. Can you help me to correct this makro ?

 

[Andrew Poulsom]

Try:

Sub Test()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Dim Rng As Range
    Dim r As Integer
    Dim c As Integer
    Dim Cell As Range
    Set Sh1 = Worksheets("Sheet1")
    Set Sh2 = Worksheets("Sheet2")
    On Error Resume Next
    Set Rng = Sh2.Columns("C:C").SpecialCells(xlCellTypeFormulas, 1)
    If Err = 0 Then
        r = 1
        c = 3
        For Each Cell In Rng.Cells
            If r > 40 Then
                r = 1
                c = c + 1
            End If
            If Cell.Value <> 0 Then
                Sh1.Cells(r, c).Value = Cell.Value
                r = r + 1
            End If
        Next Cell
    Else
        Err.Clear
    End If
    Set Rng = Sh2.Columns("D:D").SpecialCells(xlCellTypeFormulas, 1)
    If Err = 0 Then
        r = 1
        c = 1
        For Each Cell In Rng.Cells
            If Cell.Value <> 0 Then
                Sh1.Cells(r, c).Value = Cell.Value
                r = r + 1
            End If
        Next Cell
    Else
        Err.Clear
    End If
End Sub

 

[denton]

Thanks

Try:

Sub Test()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Dim Rng As Range
    Dim r As Integer
    Dim c As Integer
    Dim Cell As Range
    Set Sh1 = Worksheets("Sheet1")
    Set Sh2 = Worksheets("Sheet2")
    On Error Resume Next
    Set Rng = Sh2.Columns("C:C").SpecialCells(xlCellTypeFormulas, 1)
    If Err = 0 Then
        r = 1
        c = 3
        For Each Cell In Rng.Cells
            If r > 40 Then
                r = 1
                c = c + 1
            End If
            If Cell.Value <> 0 Then
                Sh1.Cells(r, c).Value = Cell.Value
                r = r + 1
            End If
        Next Cell
    Else
        Err.Clear
    End If
    Set Rng = Sh2.Columns("D:D").SpecialCells(xlCellTypeFormulas, 1)
    If Err = 0 Then
        r = 1
        c = 1
        For Each Cell In Rng.Cells
            If Cell.Value <> 0 Then
                Sh1.Cells(r, c).Value = Cell.Value
                r = r + 1
            End If
        Next Cell
    Else
        Err.Clear
    End If
End Sub

You are so kind! Thank you very much!!!