I am converting XML to excel. I have ID whose values are 00003233 but after conversion to excel it is 3233. I have multiples XML files so I am using code to combine all different XML files. Below is the code.
Sub From_XML_To_XL()
Dim xWb As Workbook
Dim xSWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xCount As Long
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Application.ScreenUpdating = False
Set xSWb = ThisWorkbook
xCount = 1
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
xWb.Sheets(1).UsedRange.Copy xSWb.Sheets(1).Cells(xCount, 1)
xWb.Close False
xCount = xSWb.Sheets(1).UsedRange.Rows.Count + 2
xFile = Dir()
Loop
Application.ScreenUpdating = True
xSWb.Save
Exit Sub
ErrHandler:
MsgBox "no files xml", , "Error"
End Sub
Related
I'm trying to create a macro in excel that will import .csv files from different folders into individual sheets. The code I'm using is copied from another workbook where it imports a table like A2:M10 but when I tried adapting it to this new workbook (which will import single row csv files) it compiles and runs but doesn't import anything
Sub Missing_Tools_Import()
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
xStrPath = "O:\Process Engineering\Missing Tools\CV2"
If xStrPath = "" Then Exit Sub
Worksheets("CV2").Activate
Set xSht = ThisWorkbook.ActiveSheet
xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A1:L1").End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
xStrPath = "O:\Process Engineering\Missing Tools\CV Tower"
If xStrPath = "" Then Exit Sub
Worksheets("CV Tower").Activate
Set xSht = ThisWorkbook.ActiveSheet
xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A1:L1").End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
...
Exit Sub
ErrHandler:
MsgBox "no files csv", , "Kutools for Excel"
End Sub
It repeats for 6 different sheets but none of them work.
I've played with small changes in the code with nothing happening. Most of this code I found online to begin with so I don't have a strong grasp on how it works.
xSht is the active sheet so the copy is to itself. Qualify the ranges to the relevant workbook.
Option Explicit
Sub Missing_Tools_Import()
Dim xSht As Worksheet, xWb As Workbook
Dim xFileDialog As FileDialog, f, r As Long
Dim xStrPath As String, xFile As String
Application.ScreenUpdating = False
For Each f In Array("CV2", "CV Tower")
xStrPath = "O:\Process Engineering\Missing Tools\" & f
Set xSht = ThisWorkbook.Worksheets(f)
xSht.UsedRange.Clear
r = 1
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
With xWb.Sheets(1)
.Columns(1).Insert xlShiftToRight
.Columns(1).SpecialCells(xlBlanks).Value = .Name
.UsedRange.Copy xSht.Cells(r, "A")
r = r + .UsedRange.Rows.Count
End With
xWb.Close False
xFile = Dir
Loop
Next
Application.ScreenUpdating = True
End Sub
I run a machine which puts out multiple text files which I plot, I have a VBA script which can import all of the files I want to plot from a folder and puts them on their own sheet. I was wondering if there was a way in which I could automatically have them plotted when they are imported as well? I need a separate graph for each pair of tests. That is I have "Test A-1" and "Test A-2" which are plotted against each other, "Test B-1" and "Test B-2" on a new graph etc. Sorry if this is confusing, I am still pretty new to VBA and would love a tool like this to make my life a bit easier. I have included my code which does all the importing below. Each text file (which is just data for a x-y scatter plot) is then given its own sheet, with the data in columns A and B. Apologies in advance for the terrible formatting, I didn't write it!
Sub ImportTextToExcel()
'UpdatebyExtendoffice20180911
Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Then
MsgBox "No files found", vbInformation
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Set xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
If xFiles.Count > 0 Then
For I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
ActiveSheet.Name = xWb.Name
xWb.Close False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
For xFNum = 1 To xIntRow
Set xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
If UBound(xArr) > 0 Then
For xFArr = 0 To UBound(xArr)
If xArr(xFArr) <> "" Then
xRg.Value = xArr(xFArr)
Set xRg = xRg.Offset(ColumnOffset:=1)
End If
Next
End If
Next
Next
End If
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub ImportTextToExcel()
'UpdatebyExtendoffice20180911
Dim xWb As Workbook, xToBook As Workbook, ws As Worksheet
Dim xFile As String, xStrPath As String, xStrValue As String
Dim xRg As Range, cht As Chart
Dim xFiles As New Collection
Dim i As Long
' choose folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a folder"
If .Show = -1 Then
xStrPath = .SelectedItems(1)
End If
End With
If xStrPath = "" Then
Exit Sub
ElseIf Right(xStrPath, 1) <> "\" Then
xStrPath = xStrPath & "\"
End If
' build collection of text files
xFile = Dir(xStrPath & "*.txt")
Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
If xFiles.Count = 0 Then
MsgBox "No files found", vbCritical
Exit Sub
End If
' import data
Set xToBook = ThisWorkbook
Application.ScreenUpdating = False
For i = 1 To xFiles.Count
' import data into new sheet
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
Set ws = ActiveSheet
ws.Name = xWb.Name
xWb.Close False
' split on space
Set xRg = ws.Range("A1")
xRg.CurrentRegion.TextToColumns Destination:=xRg.Cells(1, 1), _
DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, _
Space:=True, FieldInfo:=Array(Array(1, 1), Array(2, 1))
' create chart
Set cht = ws.Shapes.AddChart.Chart
With cht
.ChartType = xlXYScatter
.SetSourceData Source:=xRg.CurrentRegion
End With
Next
Application.ScreenUpdating = True
MsgBox xFiles.Count & " files imported", vbInformation
End Sub
I have a found a macro online that read in "dat" file or "text" file and put them in the open excel, creates a tab for every single file that is in the folder designated using the macro below. Now the issue is that I have to keep in re-importing new data in the same excel because data is changing or i just have to re read that file in again.
So this macro always creates a new tab if the name already exist. I need it to overwrite the data and not recreate a new tab. I have other tab that are referencing the imported data tabs. so I am not sure how to do that.
Sub loadMacro()
'UpdatebyExtendoffice6/7/2016
Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "C:\Users\"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.dat")
If xFile = "" Then
MsgBox "No files found", vbInformation, "Kutools for Excel"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Set xToBook = ThisWorkbook
If xFiles.Count > 0 Then
For I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
On Error GoTo 0
xWb.Close False
Next
End If
End Sub
Replace
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
On Error GoTo 0
with
On Error Resume Next
xToBook.Worksheets(xWb.name).Cells.Clear
With xWb.Worksheets(1).UsedRange
xToBook.Worksheets(xWb.name).Cells(1, 1).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
On Error GoTo 0
I have used the code available online to combine multiple xml files into single excel. It works fine but columns were repeated. Could someone help me in this, how to get rid of duplication while combining the xml files. Please find the code attached.
Sub From_XML_To_XL()
'UpdatebyKutoolsforExcel20151214
Dim xWb As Workbook
Dim xSWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xCount As Long
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Application.ScreenUpdating = False
Set xSWb = ThisWorkbook
xCount = 1
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
xWb.Sheets(1).UsedRange.Copy xSWb.Sheets(1).Cells(xCount, 1)
xWb.Close False
xCount = xSWb.Sheets(1).UsedRange.Rows.Count + 2
xFile = Dir()
Loop
Application.ScreenUpdating = True
xSWb.Save
Exit Sub
ErrHandler:
MsgBox "no files xml", , "Kutools for Excel"
End Sub
I have multiple CSV in one directory, I need to select specific files instead of the entire directory and I want to be able to select the column that I want (X) and import this to a single worksheet!
I have already made the code above but I'm fighting to add a input box that give the capability do select the column that I want to extract from each CSV.
Moreover, whenever I import the CSV there are not sorted correctly. I found out that I need to apply this formula ""=LEFT(F1;1)&TEXT(SUBSTITUTE(F1;LEFT(F1;1);"";"00") " ", but any idea how to apply in code in order to rename the .csv files.
Sub ImportCSVsWithReferenceI()
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xCount As Long
Dim Newname As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet.Add
Newname = InputBox("Name for new worksheet?")
If Newname <> "" Then
Sheets.Add Type:=xlWorksheet
ActiveSheet.Name = Newname
End If
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then
xSht.UsedRange.Clear
xCount = 1
Else
xCount = xSht.Cells(3, Columns.Count).End(xlToLeft).Column + 1
End If
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Rows(1).Insert xlShiftDown
Range("A1") = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Cells(1, xCount)
xWb.Close False
xFile = Dir
xCount = xSht.Cells(3, Columns.Count).End(xlToLeft).Column + 1
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "error"
End Sub
Data example (some times I want to extract the columns A or B or C or .... :
Example of a result: