Thread: Problem filling the data

Hi,

i have used this code in another workbook and it worked well. Now i've made some small changes to it to fit to a new worksheet i'm using and the procedure starts ok and when it gets to the line 140 the second time it runs a loop it breaks (i have painted the line red).

Please can someone take a look.

Thank you in advance,

Br,
Marko

Private Sub test2()

Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim wsSource As Worksheet:  Set wsSource = Sheets("Podaci")
    Dim wsForm As Worksheet:    Set wsForm = Sheets("Obrazac")
    
    Dim LastSR As Long:   LastSR = wsSource.Range("A" & Rows.Count).End(xlUp).Row
    Dim rngSR As Range:  Set rngSR = wsSource.Range("A8:A" & LastSR)
    
    Dim Datum_od As String:   Datum_od = "A9"
    Dim Datum_do As String:   Datum_do = "B9"
    
    Dim Putnik As String:    Putnik = "C11"
    Dim Marka As String:     Marka = "C12"
    Dim Registracija As String:    Registracija = "C13"
    Dim Datum As String: Datum = "A17"
      
    Dim brojacip As Integer
    
    brojacip = 0
    
    Dim wsDest As Worksheet
    Dim ws As Worksheet
    Dim iCell As Range
        
    For Each iCell In rngSR
        
        Dim wsFound As Boolean: wsFound = False
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = iCell.Value Then
                Set wsDest = ws
                wsFound = True
                Exit For
            End If
        Next ws
        
        If wsFound = False Then
            wsForm.Copy After:=Sheets(Sheets.Count)
            Set wsDest = Sheets(wsForm.Name & " (2)")
            wsDest.Name = iCell.Value
            brojacip = brojacip + 1
        End If
        
        If IsEmpty(wsDest.Range(Datum_od)) Then wsDest.Range(Datum_od).Value = Worksheets("Podaci").Cells(4, 8).Value
        If IsEmpty(wsDest.Range(Datum_do)) Then wsDest.Range(Datum_do) = Worksheets("Podaci").Cells(4, 9).Value
        If IsEmpty(wsDest.Range(Putnik)) Then wsDest.Range(Putnik).Value = iCell.Offset(0, 1).Value
        If IsEmpty(wsDest.Range(Marka)) Then wsDest.Range(Marka).Value = iCell.Offset(0, 7).Value
        If IsEmpty(wsDest.Range(Registracija)) Then wsDest.Range(Registracija).Value = iCell.Offset(0, 8).Value
        If IsEmpty(wsDest.Range(Datum)) Then
            wsDest.Range(Datum).Value = iCell.Offset(0, 2).Value
            wsDest.Range(Datum).Offset(0, 1).Value = "7:00"
            wsDest.Range(Datum).Offset(0, 2).Value = iCell.Offset(0, 4).Value
            wsDest.Range(Datum).Offset(0, 3).Value = iCell.Offset(0, 5).Value
            wsDest.Range(Datum).Offset(0, 4).Value = iCell.Offset(0, 6).Value
            wsDest.Range(Datum).Offset(0, 5).Value = ""
            wsDest.Range(Datum).Offset(0, 6).Value = iCell.Offset(0, 9).Value
            wsDest.Range(Datum).Offset(0, 7).Value = iCell.Offset(0, 10).Value
        Else
            wsDest.Range(Datum).Offset(-1, 0).End(xlDown).Offset(1, 0).Value = iCell.Offset(0, 2).Value
            wsDest.Range(Datum).Offset(-1, 1).End(xlDown).Offset(1, 0).Value = "7:00"
            wsDest.Range(Datum).Offset(-1, 2).End(xlDown).Offset(1, 0).Value = iCell.Offset(0, 4).Value
            wsDest.Range(Datum).Offset(-1, 3).End(xlDown).Offset(1, 0).Value = iCell.Offset(0, 5).Value
            wsDest.Range(Datum).Offset(-1, 4).End(xlDown).Offset(1, 0).Value = iCell.Offset(0, 6).Value
            wsDest.Range(Datum).Offset(-1, 5).End(xlDown).Offset(1, 0).Value = ""
            wsDest.Range(Datum).Offset(-1, 6).End(xlDown).Offset(1, 0).Value = iCell.Offset(0, 9).Value
            wsDest.Range(Datum).Offset(-1, 7).End(xlDown).Offset(1, 0).Value = iCell.Offset(0, 10).Value
        End If
        
    Next iCell
       
        
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    
    Application.ScreenUpdating = True

If brojacip <> 0 Then

 activeWB = ActiveWorkbook.Name
 thisSheet = Workbooks(activeWB).ActiveSheet.Name
 broj = ActiveWorkbook.Sheets.Count

 Workbooks.Add
 
 Application.DisplayAlerts = False
 Application.ScreenUpdating = False
 
 For List = 1 To broj
 Workbooks(activeWB).Sheets(List).Copy _
  before:=ActiveWorkbook.Sheets(1)
Next List
  
ActiveWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Podaci", "RTM", "Mapiranje", "Obrazac")).Delete

'Dim kk As Integer
  'For kk = 1 To Sheets.Count
    'If Worksheets(kk).Range("B9").Value <> "" Then
 '       Sheets(kk).Name = GetSaveName(Left(Worksheets(kk).Range("B9").Value, 30))
    'Else:
  '      Sheets(kk).Name = "Default (" & i & ")"
   ' End If
  'Next

Dim kk As Integer

  For kk = 1 To Sheets.Count
      If Worksheets(kk).Range("C11").Value <> "" Then
      Sheets(kk).Name = GetSaveName(Left(Worksheets(kk).Range("C11").Value, 24))
    Else:
        Sheets(kk).Name = "Default (" & i & ")"
    End If
  Next


Dim ii As Integer
Dim jj As Integer

   For ii = 1 To Sheets.Count
      For jj = 1 To Sheets.Count - 1
            If UCase$(Sheets(jj).Name) > UCase$(Sheets(jj + 1).Name) Then
               Sheets(jj).Move After:=Sheets(jj + 1)
            End If
      Next jj
   Next ii
 
ActiveWorkbook.Sheets(1).Select
Sheets(1).Cells(7, 1).Select

Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="Obrasci" & "_" & Right(Left(Worksheets(1).Range("B9").Value, 5), 2) & Right(Worksheets(1).Range("B9").Value, 4) & ".xls"
  ActiveWorkbook.Close True
  Application.DisplayAlerts = True
 Application.ScreenUpdating = True

Dim WorkbookName As String
    Dim OneWorkSheet As Worksheet
   
    WorkbookName = ActiveWorkbook.Name

  For Each OneWorkSheet In Workbooks(WorkbookName).Worksheets
   If OneWorkSheet.Name <> "Podaci" And OneWorkSheet.Name <> "Obrazac" And OneWorkSheet.Name <> "RTM" And OneWorkSheet.Name <> "Mapiranje" Then
Application.DisplayAlerts = False
OneWorkSheet.Delete

Application.DisplayAlerts = True
End If
    Next
Application.DisplayAlerts = True
 Application.ScreenUpdating = True

End If

Worksheets("Podaci").Select

 'LR = Sheets("Podaci").Cells(Rows.Count, "A").End(xlUp).Row
  '  LC = Sheets("Podaci").Cells(8, Columns.Count).End(xlToLeft).Column
    
   ' With Sheets("Podaci")
    '    .Range(.Cells(9, 1), .Cells(LR, LC)).Select
    'End With

'rng = Selection.Rows.Count
'ActiveCell.Offset(0, 0).Select
'Application.ScreenUpdating = False
'For i = 1 To rng
'If ActiveCell.Value <> 0 Then
'Selection.EntireRow.Delete
'Else
'ActiveCell.Offset(1, 0).Select
'End If
'Next i
'Application.ScreenUpdating = True


End Sub