Solved: Producing multiple spreadsheets by running data from excel database

[Beatrix]

Hi All,

I need to create a dynamic process to produce multiple excel spreadsheets by pulling data from specific columns in a small database in Excel 2010.

The thing is I convert xml files to excel spreadsheet to integrate some data with Oracle database as xml file format is not supported by Oracle database so I designed a spreadsheet to use it for this data integration process. What I need is producing multiple spreadsheets by running data from excel database into this xlsx template.

I thought I might be able to automate this process using VBA. I don’t know if there is a script used before for similar data process. I attached sample files to be clear on that.

Your help is much appreciated.

Cheers
Yeliz

[mancubus]

hi yeliz,

below is for copying columns from "xml data source.xlsx" to "template.xlsx"

first rows of "xml data source.xlsx" and "template.xlsx" contain column headers and data start at row 2. (i deleted the rows that house column numbers. you my modify the code if you want to keep that numbers.)

procedure uses cell values in Range("C2:C25") of worksheet "coding" as column numbers. so values like "25-26" are changed to "25".

in order to meet column order blank cells and or strings such as "London" in this range are filled with an empty column number, which is 1000.

i dont know the address structure. so i copied all.
this must be worked on in order to extract related parts from address string.

xlsm file is attached.

cheers.

[VBA]
Sub CopySpecificCols()

Dim baseWS As Worksheet, fromWS As Worksheet, toWS As Worksheet
Dim ColNums As Range, cll As Range, Col2Copy As Range
Dim i As Long, toLR As Long, fromLR As Long

Set baseWS = ThisWorkbook.Worksheets("coding")
Set fromWS = Workbooks("xml data source.xlsx").Worksheets("xml data source")
Set toWS = Workbooks("template.xlsx").Worksheets("template")
Set ColNums = baseWS.Range("C2:C25")

fromLR = fromWS.Cells(fromWS.Rows.Count, 1).End(xlUp).Row
toLR = toWS.Cells(toWS.Rows.Count, 1).End(xlUp).Row
If toLR = 1 Then toLR = 2
toWS.Range("A2:X" & toLR).ClearContents

i = 1
For Each cll In ColNums
With fromWS
Set Col2Copy = Range(.Cells(2, cll.Value), .Cells(fromLR, cll.Value))
End With
Col2Copy.Copy toWS.Cells(2, i)
i = i + 1
Next
toWS.Range("Q2:Q" & toWS.Cells(Rows.Count, 1).End(xlUp).Row).Value = "London"

End Sub
[/VBA]

[Beatrix]

Hi Mancubus ,

Thanks very much for your response. I've run the script but got run time error 9- saying "Subscript out of range". It goes below line when I debug the script.

[VBA]
Set fromWS = Workbooks("xml data source.xlsx").Worksheets("xml data source")
[/VBA]

I think It can't find xml data source. I put 3 files in one folder and deleted the row with the column numbers so range start at row2 as you mentioned below.

Any ideas what might be causing this error ??

Cheers
Yeliz

[mancubus]

sorry yeliz, my bad.

all 3 files must be open.

the procedure can be easily modified to open any closed files.

[Beatrix]

That's perfect! Thanks very much..

I need to run this for multiple XML files. I was wondering if it's possible to edit the script to open multiple selected files and create a template for each XML data source and then copy paste data ? Column Coding would be same for each XML file so I thought it might be possible but I don't know how difficult it is

I appreciate your time

Cheers
Yeliz

[mancubus]

you're wellcome.

i think i dont understand the requirement.

do you want xml files that you select be converted into xlsx files or template worksheets in the template.xlsx file?

[mancubus]

for the first option:

[VBA]
Sub Convert_Cols_From_XMLfiles_to_XLSXfiles()

Dim codeWB As Workbook, xmlWB As Workbook, tmpWB As Workbook
Dim codeWS As Worksheet, xmlWS As Worksheet, tmpWS As Worksheet
Dim ColNums As Range, cll As Range, Col2Copy As Range
Dim i As Long, j As Long, xmlLR As Long, tmpLR As Long, Calc As Long
Dim xmlPath As String, tmpPath As String, tmpFile As String
Dim arrFiles As Variant

With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

xmlPath = "H:\ms_ofis\dennnn\dene sil\"
tmpPath = "H:\ms_ofis\dennnn\dene sil\ConvertedFromXmlToTmp\"
If Dir(tmpPath, vbDirectory) = "" Then
MkDir tmpPath 'create folder if not exists
Else
On Error Resume Next
Kill tmpPath & "*.*" 'delete all files, if any, in folder if exists
On Error GoTo 0
End If

Set codeWB = ThisWorkbook
Set codeWS = codeWB.Worksheets("coding")
Set ColNums = codeWS.Range("C2:C25")

On Error Resume Next

Set tmpWB = Workbooks("template.xlsx")
If tmpWB Is Nothing Then Set tmpWB = Workbooks.Open(xmlPath & "template.xlsx")
Set tmpWS = tmpWB.Worksheets("template")
tmpLR = tmpWS.Cells(Rows.Count, 1).End(xlUp).Row
If tmpLR = 1 Then tmpLR = 2
tmpWS.Range("A2:X" & tmpLR).ClearContents
tmpWB.Save
tmpWB.Close

arrFiles = Application.GetOpenFilename(FileFilter:="Excel files (*.xls*), *.xls*", MultiSelect:=True)
If UBound(arrFiles) = 0 Then
MsgBox "No files selected!", vbOKOnly + vbCritical
Exit Sub
End If

On Error GoTo 0

For j = LBound(arrFiles) To UBound(arrFiles)
Set tmpWB = Workbooks.Open(xmlPath & "template.xlsx")
Set tmpWS = tmpWB.Worksheets("template")
tmpLR = tmpWS.Cells(Rows.Count, 1).End(xlUp).Row
If tmpLR = 1 Then tmpLR = 2
Set xmlWB = Workbooks.Open(arrFiles(j))
Set xmlWS = xmlWB.Worksheets("xml data source")
xmlLR = xmlWS.Cells(Rows.Count, 1).End(xlUp).Row
If xmlLR = 1 Then GoTo NextFile
i = 1
For Each cll In ColNums
Set Col2Copy = Range(xmlWS.Cells(2, cll.Value), xmlWS.Cells(xmlLR, cll.Value))
Col2Copy.Copy tmpWS.Cells(2, i)
i = i + 1
Next
tmpWS.Range("Q2:Q" & tmpWS.Cells(Rows.Count, 1).End(xlUp).Row).Value = "London"
tmpFile = "tmp_" & j & "_" & xmlWB.Name
With tmpWB
.SaveAs tmpPath & tmpFile, FileFormat:=51
.Close False
End With
xmlWB.Close False
NextFile:
Next

With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = Calc
End With

End Sub
[/VBA]

[mancubus]

second:

[VBA]
Sub Convert_Cols_From_XMLfiles_to_XLSXsheets()

Dim codeWB As Workbook, xmlWB As Workbook, tmpWB As Workbook
Dim codeWS As Worksheet, xmlWS As Worksheet, tmpWS As Worksheet, newWS As Worksheet
Dim ColNums As Range, cll As Range, Col2Copy As Range
Dim i As Long, j As Long, xmlLR As Long, tmpLR As Long, Calc As Long
Dim xmlPath As String, tmpPath As String, tmpFile As String
Dim arrFiles As Variant

With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

xmlPath = "H:\ms_ofis\dennnn\dene sil\"

Set codeWB = ThisWorkbook
Set codeWS = codeWB.Worksheets("coding")
Set ColNums = codeWS.Range("C2:C25")

On Error Resume Next

Set tmpWB = Workbooks("template.xlsx")
If tmpWB Is Nothing Then Set tmpWB = Workbooks.Open(xmlPath & "template.xlsx")
Set tmpWS = tmpWB.Worksheets("template")
tmpLR = tmpWS.Cells(Rows.Count, 1).End(xlUp).Row
If tmpLR = 1 Then tmpLR = 2
tmpWS.Range("A2:X" & tmpLR).ClearContents
tmpWB.Save
Set tmpWS = Nothing

arrFiles = Application.GetOpenFilename(FileFilter:="Excel files (*.xls*), *.xls*", MultiSelect:=True)
If UBound(arrFiles) = 0 Then
MsgBox "No files selected!", vbOKOnly + vbCritical
Exit Sub
End If

On Error GoTo 0

For j = LBound(arrFiles) To UBound(arrFiles)
Set xmlWB = Workbooks.Open(arrFiles(j))
Set xmlWS = xmlWB.Worksheets("xml data source")
xmlLR = xmlWS.Cells(Rows.Count, 1).End(xlUp).Row
If xmlLR = 1 Then GoTo NextFile
With tmpWB
.Worksheets("template").Copy After:=.Sheets(.Sheets.Count)
Set tmpWS = .ActiveSheet
tmpWS.Name = Left(xmlWB.Name, InStrRev(xmlWB.Name, ".") - 1)
End With
i = 1
For Each cll In ColNums
Set Col2Copy = Range(xmlWS.Cells(2, cll.Value), xmlWS.Cells(xmlLR, cll.Value))
Col2Copy.Copy tmpWS.Cells(2, i)
i = i + 1
Next
tmpWS.Range("Q2:Q" & tmpWS.Cells(Rows.Count, 1).End(xlUp).Row).Value = "London"
xmlWB.Close False
NextFile:
Next

tmpWB.Save

With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = Calc
End With

End Sub
[/VBA]

[mancubus]

GetOpenFilename method enables you manually select file/files.

for multiselection, click on the file names in the window while holding the CTRL key down.

[mancubus]

sorry. i forgot to say "change path to your path"

[Beatrix]

This is exactly what I was looking for Once again thanks very much!! It's working great

Cheers

for the first option:

[vba]
Sub Convert_Cols_From_XMLfiles_to_XLSXfiles()

Dim codeWB As Workbook, xmlWB As Workbook, tmpWB As Workbook
Dim codeWS As Worksheet, xmlWS As Worksheet, tmpWS As Worksheet
Dim ColNums As Range, cll As Range, Col2Copy As Range
Dim i As Long, j As Long, xmlLR As Long, tmpLR As Long, Calc As Long
Dim xmlPath As String, tmpPath As String, tmpFile As String
Dim arrFiles As Variant

With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

xmlPath = "H:\ms_ofis\dennnn\dene sil\"
tmpPath = "H:\ms_ofis\dennnn\dene sil\ConvertedFromXmlToTmp\"
If Dir(tmpPath, vbDirectory) = "" Then
MkDir tmpPath 'create folder if not exists
Else
On Error Resume Next
Kill tmpPath & "*.*" 'delete all files, if any, in folder if exists
On Error GoTo 0
End If

Set codeWB = ThisWorkbook
Set codeWS = codeWB.Worksheets("coding")
Set ColNums = codeWS.Range("C2:C25")

On Error Resume Next

Set tmpWB = Workbooks("template.xlsx")
If tmpWB Is Nothing Then Set tmpWB = Workbooks.Open(xmlPath & "template.xlsx")
Set tmpWS = tmpWB.Worksheets("template")
tmpLR = tmpWS.Cells(Rows.Count, 1).End(xlUp).Row
If tmpLR = 1 Then tmpLR = 2
tmpWS.Range("A2:X" & tmpLR).ClearContents
tmpWB.Save
tmpWB.Close

arrFiles = Application.GetOpenFilename(FileFilter:="Excel files (*.xls*), *.xls*", MultiSelect:=True)
If UBound(arrFiles) = 0 Then
MsgBox "No files selected!", vbOKOnly + vbCritical
Exit Sub
End If

On Error GoTo 0

For j = LBound(arrFiles) To UBound(arrFiles)
Set tmpWB = Workbooks.Open(xmlPath & "template.xlsx")
Set tmpWS = tmpWB.Worksheets("template")
tmpLR = tmpWS.Cells(Rows.Count, 1).End(xlUp).Row
If tmpLR = 1 Then tmpLR = 2
Set xmlWB = Workbooks.Open(arrFiles(j))
Set xmlWS = xmlWB.Worksheets("xml data source")
xmlLR = xmlWS.Cells(Rows.Count, 1).End(xlUp).Row
If xmlLR = 1 Then GoTo NextFile
i = 1
For Each cll In ColNums
Set Col2Copy = Range(xmlWS.Cells(2, cll.Value), xmlWS.Cells(xmlLR, cll.Value))
Col2Copy.Copy tmpWS.Cells(2, i)
i = i + 1
Next
tmpWS.Range("Q2:Q" & tmpWS.Cells(Rows.Count, 1).End(xlUp).Row).Value = "London"
tmpFile = "tmp_" & j & "_" & xmlWB.Name
With tmpWB
.SaveAs tmpPath & tmpFile, FileFormat:=51
.Close False
End With
xmlWB.Close False
NextFile:
Next

With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = Calc
End With

End Sub
[/vba]