VBA skips line after a few loops

[Justice98]

Hello all,

I have created a macro that creates an overview of several products, based on a cell value in a table with product codes. On the sheets where the overviews are made, I have kept column A free to be able to navigate quickly via a link (defined name ). The first five times the macro runs through successfully, but after that, the name defining step doesn't seem to run. But the rest of the entire macro works perfectly. Also when I press F8 the macro works correctly. Just not when its automated. I do need the whole range to define in connection with printing the overview. I've been looking at this for a long time now but I really can't figure it out, I hope someone can help me.

Sincerely, Justin

Here is the code that is most relevant I guess:

    Dim ActivePCode As String
    Dim Productsheetsname As String
    Dim Location1 As String
    Dim Location2 As String
    Dim Location2end As String
    Dim Location3 As String
    
    Application.ScreenUpdating = False
    
    Worksheets("ProductCodeOverview").Select
    Range("C7").Select
    Location3 = "C" & ActiveCell.Row
    
    Do Until ActiveCell.Value = ""
    
    Do While ActiveCell.Value = "Navigatie"
    
    ActiveCell.Offset(rowOffset:=1).Activate
    Loop
    
    If ActiveCell.Value = "" Then GoTo Einde
    
    Location3 = "C" & ActiveCell.Row
    Productsheetsname = Range("O" & ActiveCell.Row).Value
    
    If ActiveCell.Value <> "" Then
    ActiveCell.Offset(columnOffset:=-2).Activate
    ActiveCode = ActiveCell.Value
    ActiveCell.Offset(columnOffset:=2).Activate
    
    If DoesSheetExists(Productsheetsname) Then
    
    Sheets(Productsheetsname).Select
    
    Else
    Worksheets("Leeg blad").Copy After:=Worksheets("ProductCodeOverview")
    ActiveSheet.Name = Productsheetsname
    Range("A1").Value = "Vergeer " & Productsheetsname
    
    End If
    
    Columns("A:A").Hidden = False
    Range("A1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(rowOffset:=1).Activate
    Location1 = "B" & ActiveCell.Row
    Location2 = ActiveCell.Row
    Location2 = Location2end + 36
    Sheets("EmptyOverview").Select
    Range("A1").Activate
    Rows("2:39").Copy
    Sheets(Productsheetsname).Select
    ActiveSheet.Paste
    Range(Location1).Value = ActiveCode
    ActiveCell.Value = "Link" & ActiveCode
    'It goes wrong here!
    ActiveWorkbook.Names.Add Name:="Link" & ActiveCode, RefersToR1C1:="='" & Productsheetsname & "'!R" & Location2 & "C1:R" & Location2end & "C1"
    Columns("A:A").Hidden = True

I changed the changed the language in the macro as much I thougt was necessary.

 

[bob33]

Would likely be easier for reviewers to have an example file to work with...

 

[Justice98]

It takes a while, because I have to adjust a lot of things because there is a lot of confidential information. Is that okay with you? And how can I upload an example file?

 

[Joe4]

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

If you are unable to download that and ise that tool, you can always upload a copy of your file to a file sharing site (like your Google OneDrive account, or DropBox, etc), and share the link here.

 

[Justice98]

Sorry for the late reply, I could not make the entire file upload proof since there was a lot of confidential information in it. Now I know where it went wrong all the time, and removed some lines that just place more photos in the overviews. I translated most of the text and sheet names with Google Translate, so maybe its not always very accurate.

The file I uploaded is just a small part of the entire file, but I believe this is all we need to fix the problem. The file creates an overview of all articles named in the total overview sheet, one by one. In the overview, photos are inserted to just fit in. With one picture in a single overview a hyperlink is added. The file works entirely fine when I remove the part where the Hyperlink is added. But with the hyperlink part, the macro skips all the lines where the photos are inserted and skips the lines where the names are defined in Column A. But only when I run the macro automatically. When I run it step by step with F8, it works fine. When you need more information, please let me know.

Sub Create_Overviews()
'This macro creates an overview of all articles in the total overview, including photos.

    Dim ArticleCodeActive As String 'The article code that is currently being used. This article is included in the active loop in the overview.
    Dim ArticleSheetName As String 'The sheet name to navigate to, whether or not to create.
    Dim Location1 As String 'The cell where the active item code should be included as a value.
    Dim Location2 As String 'The cell where the active article code should be included as a link.
    Dim Location2ending As String 'The cell where the active article code should be included as a link.
    Dim Location3 As String 'The place to navigate to, after the loop ends.
    Dim ArticleWeight As String 'The weight of the packaging, needed for the path for the photos.
    Dim PhotoArticle As String 'The place where the photo of the entire article is going to be placed.
    Dim Photoloc2 As String
    Application.ScreenUpdating = False
    
    Worksheets("TotalOverviewArticles").Select
    Range("C7").Select
    Location3 = "C" & ActiveCell.Row
    
    Do Until ActiveCell.Value = ""
    
    Do While ActiveCell.Value = "Navigatie"
    
    ActiveCell.Offset(rowOffset:=1).Activate
    Loop
    
    If ActiveCell.Value = "" Then GoTo Ending
    
    Location3 = "C" & ActiveCell.Row
    ArticleSheetName = Range("O" & ActiveCell.Row).Value
    
    If ActiveCell.Value <> "" Then
    ActiveCell.Offset(Columnoffset:=-2).Activate
    ArticleCodeActive = ActiveCell.Value
    ActiveCell.Offset(Columnoffset:=2).Activate
    
    If DoesSheetExists(ArticleSheetName) Then
    
    Sheets(ArticleSheetName).Select
    
    Else
    Worksheets("Empy sheet").Copy After:=Worksheets("TotalOverviewArticles")
    ActiveSheet.Name = ArticleSheetName
    Range("A1").Value = "Customer " & ArticleSheetName
    
    End If
    
    Columns("A:A").Hidden = False
    Range("A1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(rowOffset:=1).Activate
    Location1 = "B" & ActiveCell.Row
    Location2 = ActiveCell.Row
    Location2ending = Location2 + 36
    Sheets("Empy Overview").Select
    Range("A1").Activate
    Rows("2:39").Copy
    Sheets(ArticleSheetName).Select
    ActiveSheet.Paste
    Range(Location1).Value = ArticleCodeActive
    ActiveCell.Value = "Link" & ArticleCodeActive
    ActiveWorkbook.Names.Add Name:="Link" & ArticleCodeActive, RefersToR1C1:="='" & ArticleSheetName & "'!R" & Location2 & "C1:R" & Location2ending & "C1"
    
    'I removed a view other photo locations
    Range(Location1).Select
    ActiveCell.Offset(rowOffset:=2).Activate
    PhotoArticle = ActiveCell.Address
    ActiveCell.Offset(Columnoffset:=1).Activate
    ActiveCell.Offset(rowOffset:=6).Activate
    ActiveCell.Offset(Columnoffset:=1).Activate
    ActiveCell.Offset(Columnoffset:=1).Activate
    ActiveCell.Offset(Columnoffset:=1).Activate
    Photoloc2 = ActiveCell.Address
    ActiveCell.Offset(rowOffset:=2).Activate
    ActiveCell.Offset(Columnoffset:=-1).Activate
    ActiveCell.Offset(Columnoffset:=-1).Activate
    
    'Inhoud verpakking voor pad wordt gedefinieerd.
    Range(Photoloc2).Select
    ActiveCell.Offset(rowOffset:=-6).Activate
    ActiveCell.Offset(Columnoffset:=1).Activate
    If ActiveCell.Value < 1 Then
    ArticleWeight = ActiveCell.Value * 1000 & "g"
    Else
    ArticleWeight = ActiveCell.Value & "kg"
    End If
    
    'Voorstuk dimension voor alle foto's
    Dim ws As Worksheet
    Dim targetCell As Range
    Dim picture1 As Picture

    'PhotoArticle implementatie
    On Error GoTo ErrorPhotoArticle
    Range(PhotoArticle).Select
    Set ws = ActiveSheet
    Set targetCell = ws.Range(PhotoArticle)
    Set picture1 = ws.Pictures.Insert("G:\...\" & ArticleWeight & "\" & ArticleCodeActive & "\" & ArticleCodeActive & " Article.JPG")
                                                                                                                        
    With picture1
    .ShapeRange.Line.Weight = 0.75
    .Name = ArticleCodeActive & " Article"
    .Height = targetCell.MergeArea.Height - 1.5
    .Top = targetCell.Top
    .Left = targetCell.Left + (targetCell.MergeArea.Width - .Width) / 2
    End With
    
ErrorPhotoArticle: On Error GoTo -1

    'Adds a hyperlink to the photo if the path exists, this path is different then the inserted picture.
    On Error GoTo NoLink
    Dim strFileName As String
    Dim strFileExists As String

    strFileName = "...\ProductInfo\" & ArticleCodeActive & ".jpg"
    strFileExists = Dir(strFileName)

    If strFileExists = "" Then GoTo NoLink2

    Sheets(ArticleSheetName).Shapes.Range(ArticleCodeActive & " Article").Select
    Sheets(ArticleSheetName).Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=strFileName
    
NoLink: On Error GoTo -1
NoLink2:
    
    Range("A1").Select
    Columns("A:A").Hidden = True

    Else
    End If
    
    Sheets("TotalOverviewArticles").Select
    Range(Location3).Select
    ActiveCell.Offset(rowOffset:=1).Activate
    
    Loop
    
Ending:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    Sheets("Hoofdmenu").Select
    Range("A2").Select
    
End Sub

 

[Joe4]

Without having access to your data/files, I don't think I will be able to provide much assistance.

Though I would recommend getting rid of most of your "ActiveCell" refrences. Selecting cells in your code will slow it down a bit, and is usually unnecessary to select cells in order to work with them.

For example, this:

    Range(Photoloc2).Select
    ActiveCell.Offset(rowOffset:=-6).Activate
    ActiveCell.Offset(Columnoffset:=1).Activate
    If ActiveCell.Value < 1 Then

could be simplified to this:

    If Range(Photoloc2).Offset(-6,1) < 1 Then

 

[Justice98]

Okay, I will have to discuss it first if Im allowed to share the confidential information. You hear from me within a week. Thank you for your quick answer.