Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Convert .xls to .dbf question
Message
 
General information
Forum:
Visual FoxPro
Category:
Other
Environment versions
Visual FoxPro:
VFP 9 SP1
Miscellaneous
Thread ID:
01128446
Message ID:
01128480
Views:
25
>I have to convert data from an Excel spreadsheet to a .DBF file.
>The problem is that the Excel file has no clear structure. For every "record" I need to convert there are more than one rows in the Excel file. But the number of rows is not the same for each "record". I need to "extract" from the Excel file only several cells, which are spread over several rows. Any suggestions to do it in a more of automatic/programmed way rather than manually rearrange the Excel file?
>
>Thank you in advance for any suggestions.

Dmitry,

Here is a program I recently wrote using code by my colleague and help from Sergey Berezniker on some tough issues. Hope it may help.
************************************************************
*  FUNCTION fSplitIntoDBF()
************************************************************
*  Author............: VCS Developers Team
*  Project...........: Visual Collections System
*  Created...........: 01/01/2000  17:00:00
*  Copyright.........: (c) Jzanus, 2006
*) Description.......: Takes an Excel file and makes a DBF out of it
*  Calling Samples...: fSplitIntoDBF(getfile('XLS')
*  Parameter List....: tcInputFile, tnStartFromRow, tcDbfFile
*  Major change list.:
function fSplitIntoDBF
lparameters tcInputFile, tnStartFromRow, tcDbfFile, taFieldNames

external array taFieldNames
if type('taFieldNames[1]') = 'U'
   release taFieldNames
   local array taFieldNames[1]
endif   

if empty(m.tcInputFile)
	return
endif
	
#include Excel.h

local OleApp, lcMsg, lcCellValue, lcStr, lcRange, ;
	lnRow, lnCol, lnNumSheets, lnDoneSheets, lnI, loSheet, ;
	lnRows, lnCols, llValFound, loErr, ;
	lnSameField, lnK, lnSheet, lnFinalRows, lnFinalCols

lcMsg = ""
lcCellValue = ""
lnDoneSheets = 0
if empty(m.tnStartFromRow)
	tnStartFromRow = 1
endif

try

	OleApp = createobject("Excel.Application")
*-- Open XLS File
	OleApp.application.WorkBooks.open(m.tcInputFile)

	lnNumSheets = OleApp.application.application.WorkBooks(1).Sheets.count

	for lnSheet = 1 to m.lnNumSheets

*-- Select individual sheet from opened XLS File
		loSheet = OleApp.application.application.WorkBooks(1).Sheets(m.lnSheet)
		with loSheet
			.select

			lcStr = OleApp.application.ActiveSheet.name

** Do this only for non-SUMMARY sheets in the spreadsheet
			if !("SUMMARY" $ upper(m.lcStr))

				lnDoneSheets = m.lnDoneSheets + 1

** Delete first N unused rows (help by Sergey Berezniker)
				if m.tnStartFromRow > 1
					.range("A1" , "A" + transform(m.tnStartFromRow)).EntireRow.delete()
				endif	

*-- Find total # of columns
				lnCols = .UsedRange.columns.count
				lnFinalCols = m.lnCols
				lnRows = .UsedRange.rows.count
				lnFinalRows = m.lnRows

*-- Find total # of used rows
				for lnRow = m.lnRows to 1 step -1
					llValFound = .f.
					for lnCol = m.lnCols to 1 step -1
						lcCellValue = .Cells(m.lnRow,m.lnCol).value
						if not (empty(m.lcCellValue) or isnull(m.lcCellValue))
							llValFound = .t.
							exit
						endif
					next
					if !m.llValFound
						.Rows(m.lnRow).Delete()						
						lnFinalRows = m.lnFinalRows - 1
					endif
				next

				lnRows = m.lnFinalRows &&.UsedRange.rows.count

*-- Find total # of used columns
				for lnCol = m.lnCols to 1 step -1
					llValFound = .f.
					for lnRow = m.lnRows to 1 STEP -1
						lcCellValue = .Cells(m.lnRow,m.lnCol).value
						if not (empty(m.lcCellValue) or isnull(m.lcCellValue))
							llValFound = .t.
							exit
						endif
					next
					if !llValFound
						.Columns(m.lnCols).delete()
						lnFinalCols = m.lnFinalCols - 1
					endif
				next

				lnRows =  m.lnFinalRows &&.UsedRange.rows.count
				lnCols = m.lnFinalCols && .UsedRange.columns.count

*-- Create column name array
				local array laFieldNames[m.lnCols,3]

				for lnI = 1 to m.lnCols
					lcCellValue = .Cells(1,m.lnI).value
					if vartype(m.lcCellValue) <> "C"
						if vartype(m.lcCellValue) = "N"
							lcCellValue = "_"+ alltrim(str(m.lcCellValue))
						else
							lcCellValue = "Not Valid"
						endif
					endif
					laFieldNames[m.lnI,1] = fGetFieldName(m.lcCellValue)
					laFieldNames[m.lnI,2] = alltrim(m.lcCellValue)
					laFieldNames[m.lnI,3] = m.lnI
				next

*-- SORT Field Names
				=asort(laFieldNames,1)
				lnK = 1
** Now make sure we don't have duplicates
				for lnI = 1 to m.lnCols - 1
					lnSameField = ascan(laFieldNames, laFieldNames[m.lnI,1], m.lnI + 1,-1,1,8+2)
					if m.lnSameField > 0
						laFieldNames[m.lnSameField,1] = ;
							laFieldNames[m.lnSameField,1] + transform(m.lnK)
						lnK = m.lnK + 1
					endif
				endfor
				
				acopy(laFieldNames, taFieldNames) && So we can pass an array by reference
				
** Assign new column names to the first row    
				for lnI = 1 to m.lnCols
					.Cells(1,laFieldNames[m.lnI,3]).value = laFieldNames[m.lnI,1] 
					.Range(chr(64 + m.lnI) + ":" + chr(64 + m.lnI)).Columns.ColumnWidth = ;
					.Range(chr(64 + m.lnI) + ":" + chr(64 + m.lnI)).Columns.ColumnWidth * 5 && To make sure long descriptions fit
				next

				lcRange = "A1:"
				lcRange = m.lcRange + chr(64 + m.lnCols) + alltrim(str(m.lnRows))
				
				.range(m.lcRange).select		
*				.Range("A:Z").EntireColumn.AutoFit() - doesn't work for long fields
				
				if empty(m.tcDbfFile)
					lcStr = strtran(m.lcStr,space(1),"_")
					lcStr = strtran(m.lcStr,".","_")
					lcStr = upper(strtran(upper(justfname(m.tcInputFile)),".XLS","") + ;
					"(" + m.lcStr + ")")
					tcDbfFile = sys(5)-curdir()- m.lcStr
				endif	

				OleApp.DisplayAlerts = .f.
*#DEFINE xlDBF3	8

				OleApp.ActiveWorkbook.saveas(m.tcDbfFile, xlDBF3)
			endif
		endwith
	next

	if (m.lnDoneSheets = 0)
		lcMsg = "There are no non-summary sheets in the file - cannot process."
	else
		if (m.lnDoneSheets > 1)
			lcMsg = "There are too many sheets in the file - cannot determine which to use."
		endif
	endif

	OleApp.quit

catch to loErr
	lcMsg = Log_Error(m.loErr)

endtry

OleApp = null

return m.lcMsg

endfunc

************************************************************
*  FUNCTION fGetFieldName()
************************************************************
*  Author............: VCS Developers Team
*  Project...........: Visual Collections System
*  Created...........: 01/01/2000  17:00:00
*  Copyright.........: (c) Jzanus, 2006
*) Description.......: Attempts to make a field name string
*  Calling Samples...: fGetFieldName()
*  Parameter List....: tcName
*  Major change list.:
function fGetFieldName
lparameters tcName

lcStr = alltrim(tcName)

lcAllowedChars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'+lower('ABCDEFGHIJKLMNOPQRSTUVWXYZ') + "_"+"0123456789"

lcFind = chrtran(lcStr,lcAllowedChars,space(7))

if len(lcFind) > 0
	lcStr =chrtran(lcStr,lcFind,replicate("_",len(lcFind)))
endif
lcStr = left(alltrim(lcStr),8)
if asc(left(lcStr,1)) >= asc("0") and asc(left(lcStr,1)) <= asc("9")
	lcStr = "_"+ lcStr
endif

return lcStr

endfunc
*=======================================================================
If it's not broken, fix it until it is.


My Blog
Previous
Next
Reply
Map
View

Click here to load this message in the networking platform