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.

 

[dmt32]

Hi,
untested & just a guess but see if this update to your code resolves your issue

Sub export_acc()
    Dim Rng                 As Range, cell As Range
    Dim lr                  As Long, i As Long, J As Long
    Dim wsKARTA_REALIZACJI   As Worksheet
    
    Set wsKARTA_REALIZACJI = ThisWorkbook.Worksheets("KARTA REALIZACJI")
    
    Set Rng = ActiveSheet.Range("H193:H271")
    
    With wsKARTA_REALIZACJI
    
        If .Range("B30").Value = Empty Then
            lr = .Range("B31").End(xlUp).Row
            J = 2
        Else
            lr = 30
            J = J + 9
        End If
        
    End With
    
    J = 2
    
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
            
            If lr <= 30 Then
                With wsKARTA_REALIZACJI
                
                    .Cells(lr, J).Value = ActiveSheet.Range("D" & cell.Row).Value & " " & _
                               ActiveSheet.Range("E" & cell.Row).Value
                    .Cells(lr, J + 1).Value = cell.Value
                    
                End With
            Else
                J = J + 9
                lr = 10
            End If
            
            lr = lr + 1
            
        End If
    Next cell
End Sub

if not, perhaps another here can assist as I am off out for the day


Dave

 

[mysticmario]

Hi,
untested & just a guess but see if this update to your code resolves your issue

Sub export_acc()
    Dim Rng                 As Range, cell As Range
    Dim lr                  As Long, i As Long, J As Long
    Dim wsKARTA_REALIZACJI   As Worksheet
   
    Set wsKARTA_REALIZACJI = ThisWorkbook.Worksheets("KARTA REALIZACJI")
   
    Set Rng = ActiveSheet.Range("H193:H271")
   
    With wsKARTA_REALIZACJI
   
        If .Range("B30").Value = Empty Then
            lr = .Range("B31").End(xlUp).Row
            J = 2
        Else
            lr = 30
            J = J + 9
        End If
       
    End With
   
    J = 2
   
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
           
            If lr <= 30 Then
                With wsKARTA_REALIZACJI
               
                    .Cells(lr, J).Value = ActiveSheet.Range("D" & cell.Row).Value & " " & _
                               ActiveSheet.Range("E" & cell.Row).Value
                    .Cells(lr, J + 1).Value = cell.Value
                   
                End With
            Else
                J = J + 9
                lr = 10
            End If
           
            lr = lr + 1
           
        End If
    Next cell
End Sub

if not, perhaps another here can assist as I am off out for the day


Dave

the code exprted 31 instead 19 lines, some of them were simply duplicated

 

[dmt32]

the code exprted 31 instead 19 lines, some of them were simply duplicated

poor guess then

If can use MrExcel Addin XL2BB - Excel Range to BBCode
To post copy of your worksheets (with dummy data if required) this will allow forum to test suggested changes to your code

Dave

 

[mysticmario]

poor guess then

If can use MrExcel Addin XL2BB - Excel Range to BBCode
To post copy of your worksheets (with dummy data if required) this will allow forum to test suggested changes to your code

Dave

I woudl love to pull those sheet from the whole excel to provide you for work, howevre my excel has around 200+ sheets, and even I I copy those 2 sheets used for thta task, the code will be lost somewhere in modules of the source file.

Hi,
untested & just a guess but see if this update to your code resolves your issue

Sub export_acc()
    Dim Rng                 As Range, cell As Range
    Dim lr                  As Long, i As Long, J As Long
    Dim wsKARTA_REALIZACJI   As Worksheet
  
    Set wsKARTA_REALIZACJI = ThisWorkbook.Worksheets("KARTA REALIZACJI")
  
    Set Rng = ActiveSheet.Range("H193:H271")
  
    With wsKARTA_REALIZACJI
  
        If .Range("B30").Value = Empty Then
            lr = .Range("B31").End(xlUp).Row
            J = 2
        Else
            lr = 30
            J = J + 9
        End If
      
    End With
  
    J = 2
  
    For Each cell In Rng
        If Not IsEmpty(cell) And cell.Value <> 0 Then
          
            If lr <= 30 Then
                With wsKARTA_REALIZACJI
              
                    .Cells(lr, J).Value = ActiveSheet.Range("D" & cell.Row).Value & " " & _
                               ActiveSheet.Range("E" & cell.Row).Value
                    .Cells(lr, J + 1).Value = cell.Value
                  
                End With
            Else
                J = J + 9
                lr = 10
            End If
          
            lr = lr + 1
          
        End If
    Next cell
End Sub

if not, perhaps another here can assist as I am off out for the day


Dave

Somehow after I restarted my excel, the code works perfectly fine...
now I need to apply the same thing if column J also reaches 30 items, the last items should go to column T, after that I'm good with the data transfer.

However thank you for your assitance you've been a great help.

Edit@ and I jumped the gun to hastly. When i changed some of the values imported and the ammoutn of items, the problem happens again. I restarted the excel and executed the sub, looks like pos. no 31 is being skipped and item 32 jumps in it's spot.

 

[dmt32]

However thank you for your assitance you've been a great help.

Glad solution goes in right direction & appreciate feedback

Dave

 

[mysticmario]

maybe any1 else has an idea where problenn lays

 

[mysticmario]

Myabe tackle this from the other side, I am willing to drop the idea of taking items apart to seperate columns,
However in order to do that I need to make depedency between 2 subs.
This code import from 2 to 8 items into teh spreadsheet:

Sub export_click()
Dim Rng As Range, cell As Range, lr As Long, i&, J&, mtr As Range
    lr = 10
    Set mtr = ActiveSheet.Range("E17, E50, E83, E116, E149")
    Set Rng = ActiveSheet.Range("H193:H271")
    For Each cell In mtr
        If Not IsEmpty(cell) And cell.Value <> 0 Then
            lr = lr + 1
           
            Sheets("KARTA REALIZACJI").Cells(lr, "B").Value = ("Płyta " & cell.Value)
            Sheets("KARTA REALIZACJI").Cells(lr, "C").Value = cell.Offset(20, 1).Value
            lr = lr + 1
            If cell.Offset(20, 4).Value > 0 Then
            Sheets("KARTA REALIZACJI").Cells(lr, "B").Value = ("Obrzeże " & cell.Value)
            Sheets("KARTA REALIZACJI").Cells(lr, "C").Value = cell.Offset(20, 4).Value
            Else:
                lr = lr - 1
                GoTo nextcell
               
            End If
        End If
nextcell:     Next cell
    Call export_acc
    End Sub

And this code: gets the rest of the items, but as you can see the lr is set to be static 10, which basically means it will fill the list from range B11, I need this code below to have
lr= current ummount of items already in range B11:B70
So the code fills the list with items startign from the last not empty cell.

Sub export_acc()
    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
            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
        End If
    Next cell
End Sub

I tried
lr= Application.CountA(Worksheets("KARTA REALIZACJI").Range("B11:B70"))'
and
lr=Sheets("KARTA REALIZACJI").Cells(Rows.Count, "B").End(xlUp).Row

No success

 

[mysticmario]

We can also merge these 2 subs into one I just foudn it easier to seperate them into 2 subs

 

[kokano90]

@mysticmario Try it

Option Explicit

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 < 31 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 = lr - 20
                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
            End If
        End If
    Next cell
End Sub