Copy items from sheet1.range(X:X) to next empty cell in range located in Sheet2.

[mysticmario]

As the title says I have a sheet1 and sheet2 where I neeed to check if in range H193:H271 item count is more than 0 and if yes, then copy this value + two offset values to the left, into sheet2 in empty cell in range B11:B30 and C11:C30
and if that range is full then copy those values into empty cell in range of cells next to them in this case(K11:K30 and L11:L30)
This is so what I've got so far:

Dim Rng As Range, cell As Range, lr As Long
Set Rng = Range("H193:H271")
For Each cell In Rng
    If Not IsEmpty(cell) And cell.Value <> 0 Then
    'GET ELEMENT QTY '
    lr = Sheets("KARTA REALIZACJI").Cells(Rows.Count, "C").End(xlUp).Row
    cell.Copy
        Sheets("Karta Realizacji").Cells(lr + 1, "C").PasteSpecial Paste:=xlPasteValues
     'GET ELEMENT D+E'
    lr = Sheets("KARTA REALIZACJI").Cells(Rows.Count, "C").End(xlUp).Row
    cell.Offset(0, 2).Copy
        Sheets("Karta Realizacji").Cells(lr + 1, "C").PasteSpecial Paste:=xlPasteValues

    

End If
Next cell

Of course this code doesn't work as intended it counts entie B and C column in sheet2 and it also does not combine values D and E together from sheet1.
Please also see attached screenshot for visual reference, and tips and suggestions will be a appreciated.

 

[kokano90]

Please also see attached screenshot for visual reference, and tips and suggestions will be a appreciated.

Try it

Sub ABC()
    Dim Rng As Range, cell As Range, lr As Long
    Set Rng = Sheet1.Range("H193:H271")
    lr = 10
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
            lr = lr + 1
            Sheets("Karta Realizacji").Cells(lr, "B").Value = Sheet1.Range("D" & cell.Row).Value & " " & Sheet1.Range("E" & cell.Row).Value
            Sheets("Karta Realizacji").Cells(lr, "C").Value = cell.Value
        End If
    Next cell
End Sub

 

[mysticmario]

SO the cod eabovw works perfectly fine however we need to tackle the issue where if tehre are more thna 20 itrmd "imported" I need them to go to different range, I tried this code, but it deosnt work properly.
So every item above 20 should go to coulmn K and L and every item above that 40 should go to collumn T and U.

Sub export_click()
    Dim Rng As Range, cell As Range, lr As Long
    Set Rng = ActiveSheet.Range("H193:H271")
    lr = 10
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
            lr = lr + 1
            If lr <= 20 Then
            Sheets("KARTA REALIZACJI").Cells(lr, "B").Value = ActiveSheet.Range("D" & cell.Row).Value & " " & ActiveSheet.Range("E" & cell.Row).Value
            Sheets("KARTA REALIZACJI").Cells(lr, "C").Value = cell.Value
            ElseIf lr > 20 And lr < 41 Then
            Sheets("KARTA REALIZACJI").Cells(lr, "K").Value = ActiveSheet.Range("D" & cell.Row).Value & " " & ActiveSheet.Range("E" & cell.Row).Value
            Sheets("KARTA REALIZACJI").Cells(lr, "L").Value = cell.Value
            ElseIf lr > 40 And lr < 61 Then
            Sheets("KARTA REALIZACJI").Cells(lr, "T").Value = ActiveSheet.Range("D" & cell.Row).Value & " " & ActiveSheet.Range("E" & cell.Row).Value
            Sheets("KARTA REALIZACJI").Cells(lr, "U").Value = cell.Value
            End If
        End If
    Next cell
End Sub

The results:

 

[kokano90]

Sub export_click()
    Dim Rng As Range, cell As Range, lr As Long, i&, J&
    Set Rng = Arkusz2.Range("H193:H271")
    lr = 10: J = 2
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
            lr = lr + 1: i = i + 1
            If i Mod 21 <> 0 Then
                Sheets("KARTA REALIZACJI").Cells(lr, J).Value = ActiveSheet.Range("D" & cell.Row).Value & " " & ActiveSheet.Range("E" & cell.Row).Value
                Sheets("KARTA REALIZACJI").Cells(lr, J + 1).Value = cell.Value
            Else
                J = J + 9
                lr = 10
            End If
        End If
    Next cell
End Sub