Missing value, trying to find problem source in the code not written by me.

[mysticmario]

Hi there,
I have 2 excel sheets one copies value to the other based on if qty has been given or not.

I am at the finish line and i asked someone to help me to code snippet of code, which allows smooth transition to collumn J if item count on sheet reaches B30. (sheet 2)
Long story short the code has inherited problem where it skips the one item which should be first positions in collumn J. Person who wrote the code either intentionaly or not coded that and in order to fix it he demands money, despite telling me previously he would help me with it free of charge out, because he likes to help...
Now I am stuck with a problem that I did not create myself and his code is not my level so I can't find the source of the problem. Can you help me find the problem?
(providing code and screenshots below)

Here's the code:

Sub export_acc()
    Dim Rng As Range, cell As Range, lr As Long, i&, J&
    Set Rng = ActiveSheet.Range("H193:H271")
    If Sheets("KARTA REALIZACJI").Range("B30").Value = Empty Then
        lr = Sheets("KARTA REALIZACJI").Range("B31").End(3).Row
        J = 2
    Else
        lr = 30
        J = J + 9
    End If
    J = 2
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
            lr = lr + 1
            If lr <= 30 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

And some screenshots for refference.



Thank you in advance for your assitance.

 

[kokano90]

@mysticmario edit code:

Sub export_acc()
    Dim Rng As Range, cell As Range, lr As Long, i&, J&, S, T%,X
    Dim Ws As Worksheet
    Application.ScreenUpdating = 0
    Set Ws = Sheets("KARTA REALIZACJI")
    Set Rng = Arkusz2.Range("H193:H271")
    S = Array("B", "K", "T")
    With Ws
        T = Application.WorksheetFunction.CountA(.Range("B11:B30,K11:K30,T11:T30"))
        If T >= 60 Then MsgBox "Full line.Please check data": Exit Sub
        If T > 0 Then
            x = Int(T / 20)
            lr = .Cells(30, S(x)).End(3).Row
        Else
            lr = 10
            x = 0
        End If
    End With
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
            lr = lr + 1
            If lr < 31 Then
                If x <= 2 Then
                    Ws.Cells(lr, S(x)).Value = Arkusz2.Range("D" & cell.Row).Value & " " & Arkusz2.Range("E" & cell.Row).Value
                    Ws.Cells(lr, S(x)).Offset(, 1).Value = cell.Value
                Else
                    MsgBox "Check the return area": Exit Sub
                End If
            Else
                x = x + 1
                lr = lr - 20
                If x <= 2 Then
                    Ws.Cells(lr, S(x)).Value = Arkusz2.Range("D" & cell.Row).Value & " " & Arkusz2.Range("E" & cell.Row).Value
                    Ws.Cells(lr, S(x)).Offset(, 1).Value = cell.Value
                Else
                    MsgBox "Check the return area": Exit Sub
                End If
            End If
        End If
    Next cell
    Application.ScreenUpdating = 1
    MsgBox "Done"
End Sub

 

[mysticmario]

Thank you, works great