CSV export

As I get used to using Assisi I find the Cruise.xlsm to be buggy a hard to use. Many time when attempting to validate the data it deletes fields and replaces the with "#Value!". I find importing data using .csv files to be a little more consistent.

That being said the Import feature within Assisi requires .ini files to map the schema. I created an Excel Macro that outputs these and the .csv files based on data in sheets. The only thing you need to do is name your Sheets and make sure the Column names match the column in the database.

The current version works for Cruise, Plots and Trees tables. Note that each sheet will need the "ThisSheet" object set to match the sheet names.

Just copy and past this whole mess in and Excel Module. Feel free to add or alter any of this code.

Enjoy!

Option Explicit

Declare PtrSafe Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Public Sub ExportToIni(headers As Range, csvName As String, iniPath As String)

If Dir(iniPath) <> "" Then Kill iniPath

WritePrivateProfileString csvName, "ColNameHeader", "True", iniPath

Open iniPath For Append As #1

Print #1, "Format=CSVDelimited"

Dim c As Range

Dim i As Integer

Dim datatype As String

i = 1

For Each c In headers

Select Case c.Value

Case "Unit": datatype = "Char"

Case "Stand": datatype = "Char"

Case "Cruise": datatype = "Char"

Case "Plot": datatype = "Long"

Case "Tree": datatype = "Long"

Case "SubPlot": datatype = "Long"

Case "Count": datatype = "Single"

Case "Species": datatype = "Char"

Case "DBH": datatype = "Single"

Case "FormFactor": datatype = "Single"

Case "FormPointHeight": datatype = "Single"

Case "CrownBaseHeight": datatype = "Single"

Case "CrownClass": datatype = "Char"

Case "MerchHeight": datatype = "Single"

Case "MerchDiameter": datatype = "Single"

Case "MerchPercentDiameter": datatype = "Single"

Case "TotalHeight": datatype = "Single"

Case "IsBrokenTop": datatype = "Bit"

Case "BrokenHeight": datatype = "Single"

Case "BrokenDiameter": datatype = "Single"

Case "IsSiteTree": datatype = "Bit"

Case "BreastHeightAge": datatype = "Single"

Case "IsOffPlot": datatype = "Bit"

Case "Damage": datatype = "Char"

Case "DecayClass": datatype = "Char"

Case "BoardDefect": datatype = "Single"

Case "IsSnag": datatype = "Bit"

Case "IsStanding": datatype = "Bit"

Case "Notes": datatype = "Char"

Case "CruiseDesign": datatype = "Char"

Case "CruiseDate": datatype = "Date"

Case "Area": datatype = "Single"

Case "StandType": datatype = "Char"

Case "SubPlot1BAF": datatype = "Single"

Case "SubPlot1MinDBH": datatype = "Single"

Case "SubPlot2Radius": datatype = "Single"

Case "StandNotes": datatype = "Char"

Case "Recorder": datatype = "Char"

Case "Latitude": datatype = "Single"

Case "Longitude": datatype = "Single"

End Select

Print #1, "Col" & i & "=" & Chr(34) & CStr(c.Value) & Chr(34) & " " & datatype

i = i + 1

Next

Close #1

End Sub

Public Sub ExportCSV(headerRange As Range, CurrentSheet As Worksheet, PathName As String)

Dim totline As Long

Dim lastcol As Long

Dim i As Long

Dim TempWB As Workbook

Dim sheetname As String: sheetname = CurrentSheet.Name

Dim k As Long

totline = CurrentSheet.Range("A" & Rows.Count).End(xlUp).Row

lastcol = CurrentSheet.Cells(1, CurrentSheet.Columns.Count).End(xlToLeft).Column

headerRange.Copy

Set TempWB = Application.Workbooks.Add(1)

TempWB.Sheets(1).Name = sheetname

TempWB.Sheets(sheetname).Range("A1").PasteSpecial xlPasteValues

For i = 2 To totline

TempWB.Sheets(sheetname).Range(TempWB.Sheets(sheetname).Cells(i, 1), TempWB.Sheets(sheetname).Cells(i, lastcol)).Value _

= CurrentSheet.Range(CurrentSheet.Cells(i, 1), CurrentSheet.Cells(i, lastcol)).Value

Next i

Application.DisplayAlerts = False

TempWB.SaveAs Filename:=PathName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True

TempWB.Close savechanges:=False

Application.DisplayAlerts = True

End Sub

Sub ExportData()

Dim ThisSheet As Worksheet

Dim FilePath As String

Dim MyFolder As String

Dim MyFileName As String

Dim FolderExists As String

Dim Project As String

Dim headerRange As Range

Dim Nname As String, iniName As String

Dim ThisName As String

FilePath = ThisWorkbook.Path

Project = "CSV Export(" & Format(Date, "mm dd yyyy") & ")\" '<<<<Folder name

'*********************Create Folder**********************

FilePath = FilePath & "\" & Project

FolderExists = Dir(FilePath, vbDirectory)

If FolderExists = "" Then

MkDir (FilePath)

End If

'*****************************************************Stands_List*********************************************************

'-------Hard set these values------------------------

Set ThisSheet = ThisWorkbook.Sheets("Cruise")

With ThisSheet

Set headerRange = .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column))

End With

'----------------------------------------------------

Nname = ThisSheet.Name & ".csv"

iniName = ThisSheet.Name & ".ini"

MyFileName = FilePath & Nname

'create ini file for import to Assisi

ExportToIni headerRange, Nname, FilePath & iniName

'create .csv file

ExportCSV headerRange, ThisSheet, MyFileName

'*****************************************************Plots_List*********************************************************

'-------Hard set these values------------------------

Set ThisSheet = ThisWorkbook.Sheets("Plots")

With ThisSheet

Set headerRange = .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column))

End With

'----------------------------------------------------

Nname = ThisSheet.Name & ".csv"

iniName = ThisSheet.Name & ".ini"

MyFileName = FilePath & Nname

'create ini file for import to Assisi

ExportToIni headerRange, Nname, FilePath & iniName

'create .csv file

ExportCSV headerRange, ThisSheet, MyFileName

'*****************************************************Tree_List*********************************************************

'-------Hard set these values------------------------

Set ThisSheet = ThisWorkbook.Sheets("Trees")

With ThisSheet

Set headerRange = .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column))

End With

Nname = ThisSheet.Name & ".csv"

iniName = ThisSheet.Name & ".ini"

MyFileName = FilePath & Nname

'create ini file for import to Assisi

ExportToIni headerRange, Nname, FilePath & iniName

'create .csv file

ExportCSV headerRange, ThisSheet, MyFileName

MsgBox ("Data Successfully Exported")

End Sub