Export all maps (mappings for all dimensions in EXCEL)

Question

Hi,
it shouldn't be an unknown issue - but unfortunately I can't find the way :-(

Answer 1

Below is updated code with the following changes :
- Adjusted SaveAs logic to prevent Excel prompts in the event the file already exists, etc. (i.e. DisplayAlerts TRUE / FALSE)
- Added Range creation logic for each worksheet page. If I really wanted perfect code, could do this better, but it gets the job done.
Sub ExportAllCurrDimMapsForLocationtoXLS()
'UpStream WebLink DM Custom Script:
'Created By:         cbeyer
'Date Created:       11-23-11
'Purpose:               Export all dimension maps to an Excel workbook      
'Declare Constant
'NOTE : This will control whether the function gets the current map in the system or whether it looks back for a specific Period
'       FDM stores the Map for each period that was loaded... You may want to export a particular POV Period for audit purposes, etc.
'       IF you enable this, be sure to set the POV Period before running.....
Const boolgetPOVPeriodMap = False
'Declare working variables
Dim intPartitionKey
Dim strOutputMessage
Dim strSQL
Dim strCategoryFreq
Dim objPeriodKey
Dim strOutputFileName
Dim strOutputFilePath
'Get the location (PartitionKey
intPartitionKey = RES.PlngLocKey
'Create SQL Query to get Current Map Data
If boolgetPOVPeriodMap = False Then
     strSQL = "SELECT * FROM tDataMap where PartitionKey = " & intPartitionKey & " order by DimName ASC"
Else
     strCategoryFreq = API.POVMgr.fCategoryFreq(API.POVMgr.PPOVCategory)
     Set objPeriodKey = API.POVMgr.fPeriodKey(API.POVMgr.PPOVPeriod, 0, strCategoryFreq)
     strSQL = "SELECT * from vDataMap where PartitionKey = " & intPartitionKey & " and PeriodKey = '" & objPeriodKey.dteDateKey & " 12:00:00 AM' order by DimName Asc"
End If
'Create Recordset for all Exported Entities
Set rsMap = DW.DataAccess.farsKeySet(strSQL)
If rsMap.EOF And rsMap.BOF Then
     'No records
     If boolgetPOVPeriodMap = False Then
          strOutputMessage = "No Mapping data was found For " & API.POVMgr.PPOVLocation & ".  If this location Is using Parent Maps, you can only export mapping data at the parent location."     
     Else
          strOutputMessage = "No Mapping data was found For " & API.POVMgr.PPOVLocation & " for period " & API.POVMgr.PPOVPeriod & ".  If this location Is using Parent Maps, you can only export mapping data at the parent location."          
     End If
Else
     'Records Exist, process
     'Generate file name / path
     If boolgetPOVPeriodMap = False Then
          strOutputFileName = API.POVMgr.PPOVLocation & "_DimensionMaps.xls"
     Else
          strOutputFileName = API.POVMgr.PPOVLocation & "_" & objPeriodKey.strDateKey & "_DimensionMaps.xls"
     End If
     strOutputFilePath = DW.Connection.PstrDirOutbox & "\ExcelFiles\"
     'Create Excel file reference     
     'Declare Excel working variables
     Dim oExcel
     Dim oBook
     Dim oSheet 'No puns here......
     Dim oRange
     Dim intCurrentSheetOrdinal
     Dim intCurrentRowOrdinal
     Dim intCurrentColOrdinal
     'Intialize Excel
     Set oExcel = CreateObject("Excel.Application")
     Set oBook = oExcel.Workbooks.Add
     'Declare working variables
     Dim strCurrDimName
     'Initialize variables
     strCurrDimName = ""
     intCurrentSheetOrdinal = 1
     intCurrentRowOrdinal = 1
     intCurrentColOrdinal = 1
     With rsMap
          Do Until .eof
               'Check to see if current DimName matches existing DimName.  If not, add headers
               If rsMap.fields("DimName") <> strCurrDimName Then
                     'If the dimension name has changed to a different dimension name, show total information before starting headers
                     'If the previous dimension was not "", then we are transitioning from one range to the next.  Lets create a named range on the just
                     'finished worksheet because we can or because you may want to use this for re-uploading
                     'NOTE : The range I'm creating is more for reference as to how to implement this and I don't know if I'm making the range in a fashion that
                     'FDM will pickup for importing. 
                     'NOTE : You probably want intCurrentRowOrdinal - 1 since it is 1 row past the last row of data at this point.  If you want to clean it up,
                     'then you need to make sure RowOrdinal is not going to be less than the starting point and I didn't feel like adding the couple rows of
                     'code to do the work properly as FDM will just ignore the blank row in all likelihood.
                                                                  If strCurrDimName <> "" Then
                            Set oRange = oSheet.Range("A6:K" & intCurrentRowOrdinal)
                            oBook.Names.Add "ups"&strCurrDimName, oRange
                     End If
                     'Create worksheet reference
                       Set oSheet = oBook.Worksheets(intCurrentSheetOrdinal)                    
                      'Create default header at top of each new dimension group
                         If boolgetPOVPeriodMap = False Then
                              oSheet.range("A1") = (API.POVMgr.PPOVLocation & " - Map Conversion")
                         Else
                              oSheet.range("A1") = (API.POVMgr.PPOVLocation & " - Map Conversion for " & rsMap.fields("PeriodKey"))
                         End If
                         oSheet.range("A3") = "Partition: " & API.POVMgr.PPOVLocation
                         oSheet.range("A4") = "User ID: " & DW.Connection.PstrUserID
                         'NOTE: I could make an array of the field names and do a loop here; however, this is easier to read.....
                         '      probably not how I would do it from an efficiency standpoint, but since it's a limited number of fields
                         '      this will work.....
                             oSheet.range("A5") = "PartitionKey"
                             oSheet.range("B5") = "DimName"
                             oSheet.range("C5") = "Source FM Account"
                             oSheet.range("D5") = "Description"
                             oSheet.range("E5") = "Target FM Account"
                             oSheet.range("F5") = "WhereClauseType"
                             oSheet.range("G5") = "WhereClauseValue"
                             oSheet.range("H5") = "-"
                             oSheet.range("I5") = "Sequence"
                             oSheet.range("J5") = "DataKey"
                             oSheet.range("K5") = "VBScript"
                         'Update variables                   
                            strCurrDimName = rsMap.fields("DimName")
                            intCurrentRowOrdinal = 6
                            intCurrentSheetOrdinal = intCurrentSheetOrdinal + 1
                            'Update worksheet name
                            oSheet.name = strCurrDimName
               End If
                 'Write Details
                        oSheet.range("A" & intCurrentRowOrdinal) = intPartitionKey
                 oSheet.range("B" & intCurrentRowOrdinal) = rsMap.fields("DimName").Value
                 oSheet.range("C" & intCurrentRowOrdinal) = rsMap.fields("SrcKey").Value
                 oSheet.range("D" & intCurrentRowOrdinal) = rsMap.fields("SrcDesc").Value
                 oSheet.range("E" & intCurrentRowOrdinal) = rsMap.fields("TargKey").Value
                 oSheet.range("F" & intCurrentRowOrdinal) = rsMap.fields("WhereClauseType").Value
                 oSheet.range("G" & intCurrentRowOrdinal) = rsMap.fields("WhereClauseValue").Value
                 oSheet.range("H" & intCurrentRowOrdinal) = rsMap.fields("ChangeSign").Value
                 oSheet.range("I" & intCurrentRowOrdinal) = rsMap.fields("Sequence").Value
                 oSheet.range("J" & intCurrentRowOrdinal) = rsMap.fields("DataKey").Value
                 oSheet.range("K" & intCurrentRowOrdinal) = rsMap.fields("VBScript").Value
               'Increment Counters
               intCurrentRowOrdinal = intCurrentRowOrdinal + 1
               'Move to the next record
               .movenext
          Loop
     End With
     'Final Sheet Named Range addition
     'Since the loop will end and we will not execute the above logic to create the range for the previous sheet
     'the easiest (laziest) solution is to just handle the last sheet after the loop.
     'We're basically doing the same stuff we did above, just down here.
      If strCurrDimName <> "" Then
          Set oRange = oSheet.Range("A6:K" & intCurrentRowOrdinal)
           oBook.Names.Add "ups"&strCurrDimName, oRange
      End If      
     'Close / release file objects
     'Added some logic here to ensure you don't get caught up on the file replace prompt.
     oExcel.Application.DisplayAlerts = False
     oBook.SaveAs strOutputFilePath & strOutputFileName
     oExcel.Application.DisplayAlerts = True
     oExcel.Quit
     'Create output message          
     strOutputMessage = "Mapping data export for " & API.POVMgr.PPOVLocation  & " complete.  Extract file is : " & strOutputFilePath & strOutputFileName
End If
'Close / release data objects
rsMap.close
'Display output
If LCase(API.DataWindow.Connection.PstrClientType) = "workbench" Then
          MsgBox strOutputMessage       
Else
     'Let the user know we are done
     RES.PlngActionType = 2
     RES.PstrActionValue = strOutputMessage
End If
End SubEdited by: beyerch2 on Dec 14, 2011 9:43 AM