VBA Help using loop

[Aviator08]

Hello,

I am trying to write a code where it copies a number from a provided list, pastes the number in a cell, calculates to update, then saves that tab in a folder and breaks the links before saving the file. The macro repeats this process till there are no more numbers to copy. I am having issues on the saving portion of the macro. I added a step to copy the tab in a new book, break links and then save the file.

The first issue I have when it saves, is that it saves it as an XPS file. The second issue is that the loop fails and I get a Debug error. I am no where near familiar with VBA, i used some old coding from another macro and trying to fit into this, so my apologies in advanced if it is horrible. Below is the code so far. Thank you.


Sub CreateStoreTargets()


Set shtTarget = Worksheets("StoreLabor")


Do Until Sheets("VBA - Comp Store List").Range("B1") = ""
StoreID = Sheets("VBA - Comp Store List").Range("B1").Value
District = Sheets("VBA - Comp Store List").Range("C1").Value

Sheets("StoreLabor").Select
Cells.Select
With Selection.Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
Range("A2").Select
Sheets("VBA - Comp Store List").Select
Range("A1").Select
Selection.Copy
Sheets("StoreLabor").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Application.Calculate
Sheets("VBA - Comp Store List").Select
Range("A1:C1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp


Sheets("StoreLabor").Select
Sheets("StoreLabor").Copy


' Define variable as an Excel link type.
astrLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)

' Break the first link in the active workbook.
ActiveWorkbook.BreakLink _
Name:=astrLinks(1), _
Type:=xlLinkTypeExcelLinks

ActiveSheet.ExportAsFixedFormat Type:=xlExcelLinks, Filename:=strFilePath1 & StoreID & strFilePath2 & strReportTitle1 & StoreID & strReportTitle2 & strDateFooter & strFilePath3, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Loop

ThisWorkbook.Saved = False
Application.Quit

End Sub

 

[HaHoBe]

Hi Aviator08,

maybe as a start

Public Sub MrE_1226151_170080D()
' https://www.mrexcel.com/board/threads/vba-help-using-loop.1226151/

Dim wsTarget As Worksheet
Dim wsData As Worksheet
Dim varStoreID As Variant
Dim varDistrict As Variant
Dim astrLinks As Variant

'all these componenets are mentioned but no value has been assigned to them in the code
'you would need to change the contents to suit
Const strFilePath1 As String = "C:\Result\"
Const strFilePath2 As String = "\Test\"
Const strReportTitle1 As String = "My Report "
Const strReportTitle2 As String = " Quartal 1"
Const strDateFooter As String = "20230107"
Const strFilePath3 As String = "_xx_yy_zz"

Set wsTarget = Worksheets("StoreLabor")
Set wsData = Worksheets("VBA - Comp Store List")

Do Until wsData.Range("B1") = ""
  varStoreID = wsData.Range("B1").Value
  varDistrict = wsData.Range("C1").Value
  
  With wsTarget.Cells.Font
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
  End With
  wsTarget.Range("A2").Value = wsData.Range("A1").Value
  Application.Calculate
  wsData.Range("A1:C1").Delete Shift:=xlUp
  
  wsTarget.Copy
  
  ' Define variable as an Excel link type.
  On Error Resume Next
  astrLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
  
  ' Break the first link in the active workbook.
  ActiveWorkbook.BreakLink _
    Name:=astrLinks(1), _
    Type:=xlLinkTypeExcelLinks
  Err.Clear
  On Error GoTo 0
  
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=strFilePath1 & varStoreID & strFilePath2 & strReportTitle1 & _
              varStoreID & strReportTitle2 & strDateFooter & strFilePath3, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
  ActiveWorkbook.Close False
Loop

Set wsData = Nothing
Set wsTarget = Nothing
ThisWorkbook.Saved = False
Application.Quit

End Sub

Ciao,
Holger

 

[Aviator08]

Hi Aviator08,

maybe as a start

Public Sub MrE_1226151_170080D()
' https://www.mrexcel.com/board/threads/vba-help-using-loop.1226151/

Dim wsTarget As Worksheet
Dim wsData As Worksheet
Dim varStoreID As Variant
Dim varDistrict As Variant
Dim astrLinks As Variant

'all these componenets are mentioned but no value has been assigned to them in the code
'you would need to change the contents to suit
Const strFilePath1 As String = "C:\Result\"
Const strFilePath2 As String = "\Test\"
Const strReportTitle1 As String = "My Report "
Const strReportTitle2 As String = " Quartal 1"
Const strDateFooter As String = "20230107"
Const strFilePath3 As String = "_xx_yy_zz"

Set wsTarget = Worksheets("StoreLabor")
Set wsData = Worksheets("VBA - Comp Store List")

Do Until wsData.Range("B1") = ""
  varStoreID = wsData.Range("B1").Value
  varDistrict = wsData.Range("C1").Value
 
  With wsTarget.Cells.Font
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
  End With
  wsTarget.Range("A2").Value = wsData.Range("A1").Value
  Application.Calculate
  wsData.Range("A1:C1").Delete Shift:=xlUp
 
  wsTarget.Copy
 
  ' Define variable as an Excel link type.
  On Error Resume Next
  astrLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
 
  ' Break the first link in the active workbook.
  ActiveWorkbook.BreakLink _
    Name:=astrLinks(1), _
    Type:=xlLinkTypeExcelLinks
  Err.Clear
  On Error GoTo 0
 
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=strFilePath1 & varStoreID & strFilePath2 & strReportTitle1 & _
              varStoreID & strReportTitle2 & strDateFooter & strFilePath3, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
  ActiveWorkbook.Close False
Loop

Set wsData = Nothing
Set wsTarget = Nothing
ThisWorkbook.Saved = False
Application.Quit

End Sub

Ciao,
Holger

Hello,

Thank you for the help. A few things I learned and would like to change from this code. I was not aware the ExportAsFixedFormat meant it would be PDF or XPS. I would like to save the sheet that I copied ("StoreLabor") into a new workbook as an Excel worksheet (.XLSX). My other question is on how/where in the code does it close the new book after it has saved it in the path assigned and go back to the original file and continues going down the list of numbers provided? Again, thanks a lot for your help and time.

 

[HaHoBe]

Hi Aviator08,

changes are commented in the code:

Public Sub MrE_1226151_170080D_mod()
' https://www.mrexcel.com/board/threads/vba-help-using-loop.1226151/
' Updated: 20230111
' Reason:  changed from saving as PDF to saving as macrofree workbook

Dim wsTarget As Worksheet
Dim wsData As Worksheet
Dim varStoreID As Variant
Dim varDistrict As Variant
Dim astrLinks As Variant

'all these componenets are mentioned but no value has been assigned to them in the code
'you would need to change the contents to suit
Const strFilePath1 As String = "C:\Result\"
Const strFilePath2 As String = "\Test\"
Const strReportTitle1 As String = "My Report "
Const strReportTitle2 As String = " Quartal 1"
Const strDateFooter As String = "20230107"
Const strFilePath3 As String = "_xx_yy_zz"

Set wsTarget = Worksheets("StoreLabor")
Set wsData = Worksheets("VBA - Comp Store List")

Do Until wsData.Range("B1") = ""
  varStoreID = wsData.Range("B1").Value
  varDistrict = wsData.Range("C1").Value
  
  With wsTarget.Cells.Font
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
  End With
  wsTarget.Range("A2").Value = wsData.Range("A1").Value
  Application.Calculate
  wsData.Range("A1:C1").Delete Shift:=xlUp
  
  wsTarget.Copy
  
  ' Define variable as an Excel link type.
  On Error Resume Next
  astrLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
  
  ' Break the first link in the active workbook.
  ActiveWorkbook.BreakLink _
    Name:=astrLinks(1), _
    Type:=xlLinkTypeExcelLinks
  Err.Clear
  On Error GoTo 0
  
  '/// assuming that there is no extension for the file added to strFilePath3
  '/// I would use another variable to combine the parts and use that variable to store as it would hold
  '/// the information about drive, folder and name/extension of the workbook in one place
  ActiveWorkbook.SaveAs Filename:=strFilePath1 & varStoreID & strFilePath2 & strReportTitle1 & _
              varStoreID & strReportTitle2 & strDateFooter & strFilePath3 & ".xlsx", FileFormat:=51 'xlOpenXMLWorkbook
  '/// next command closes new workbook without saving, last activeworkbook before gets the focus again
  ActiveWorkbook.Close False
Loop

Set wsData = Nothing
Set wsTarget = Nothing
ThisWorkbook.Saved = False
Application.Quit

End Sub

Holger