I have a macro 'macro1' that convert all *.xls files within a folder to *.csv. After converting them, I merge rows using the command prompt. The I convert the merged file into an xls using macro2. Everything is working fine but when a value is something like 123456789123456 the resulting csv value is something like 1234E+11. How to keep the number format between converted files?
here are my macros
macro1
Option Explicit
Sub ConvertToCSV()
Dim i As Long
Dim NumFiles As Long
Dim FileName As String
Dim FileNames() As String
FileName = Dir(ThisWorkbook.Path & "/*.xls")
NumFiles = 1
ReDim Preserve FileNames(1 To NumFiles)
FileNames(NumFiles) = FileName
Do While FileName <> ""
FileName = Dir()
If FileName <> "" Then
NumFiles = NumFiles + 1
ReDim Preserve FileNames(1 To NumFiles)
FileNames(NumFiles) = FileName
End If
Loop
Application.DisplayAlerts = False
For i = 1 To UBound(FileNames)
If FileNames(i) <> ThisWorkbook.Name Then
Workbooks.Open FileName:=ThisWorkbook.Path & "\" & FileNames(i)
ActiveWorkbook.SaveAs _
FileName:=Left(FileNames(i), Len(FileNames(i)) - 4) & ".csv", _
FileFormat:=xlCSV
ActiveWorkbook.Close
End If
Next i
Application.DisplayAlerts = True
End Sub
and the macro2
Sub FromCSVToXLS()
Dim myWB As Workbook, WB As Workbook
Dim L As Long, x As Long, i As Long
Dim v As Variant
Dim myPath
Dim myFile
Set myWB = ThisWorkbook
Application.ScreenUpdating = False
Sheets(1).Cells.ClearContents
myPath = "C:\Folder1\Folder2\" '<<< change path
myFile = "myFile.csv" '<<< change file name
Set WB = Workbooks.Open(myPath & myFile)
ActiveSheet.UsedRange.Copy myWB.Sheets(1).Range("A1")
ActiveWorkbook.Close False
L = myWB.Sheets(1).UsedRange.Rows.Count
For i = 1 To L
v = Split(Cells(i, 1), ",")
For x = 0 To UBound(v)
Cells(i, x + 1) = v(x)
Next x
Next i
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= "D:\data folder\1.xls"
Application.DisplayAlerts = True
myWB.Save
Application.ScreenUpdating = True
End Sub
PS: the command prompt is not altering the number format. VERIFIED!
Thank you
SOLVED!!
I did this:
Open the merged file
select the concerned column
right clic on the column
and I changed the format of all column's cells.
Related
I am trying to copy a fixed column from files in a folder, I am extracting column N only and pasting them onto an active sheet with columns right next to each other. However, I am getting error message, please help me
Sub LoopThroughDirectory()
Dim MyFile As String
Dim Filepath As String
Dim Wb As Workbook, _
Ws As Worksheet, _
PasteRow As Long
Filepath = "\\123.20.0.89\Risk_dept\"
Set Ws = ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
PasteCloumn = Ws.Range("A" & Ws.Columns.Count).End(xlToRight).Column + 1
Set Wb = Workbooks.Open(Filepath & MyFile)
Worksheets("part 5").Range("N2:N200").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("A:A").End(xlToRight).Column + 1
Applicaiotn.CutCopyMode = False
MyFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This works for me. Extracts column N from files in folder and pastes them into active sheet.
Sub LoopThroughDirectory()
Dim filePath As String, target As Worksheet, file As String, wb As Workbook, col As Long
filePath = "\\123.20.0.89\Risk_dept\"
Set target = ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
file = Dir(filePath)
Do While Len(file) > 0
If file = "zmaster.xlsm" Then
Exit Sub
End If
Set wb = Workbooks.Open(filePath & file)
col = target.Range("A1").End(xlToRight).Column + 1
wb.Worksheets("part 5").Range("N2:N200").Copy Destination:=target.Cells(1, col)
file = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I've created a tool and the below macro copies all .csv files into a excel sheet. I want the data to be copied to the "Consol.xlsx" file that I created. The current code copies the data in the tool not the "Consol.xlsx" file. I am unable to update the code so that the data gets copied correctly.
Below is my code:
Sub Button_click2()
Call AddNew
Call ImportCSVsWithReference
End Sub
Sub AddNew()
Application.DisplayAlerts = False
Dim thisWb As Workbook
Set thisWb = ActiveWorkbook
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=thisWb.path & "\Consol.xlsx"
Application.DisplayAlerts = True
End Sub
Sub ImportCSV()
Dim strSourcePath As String
Dim strDestPath As String
Dim strFile As String
Dim strData As String
Dim x As Variant
Dim Cnt As Long
Dim r As Long
Dim c As Long
Application.ScreenUpdating = False
'Change the path to the source folder accordingly
strSourcePath = Application.ActiveWorkbook.path
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
'Change the path to the destination folder accordingly
strDestPath = Application.ActiveWorkbook.path
If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"
strFile = Dir(strSourcePath & "*.csv")
Do While Len(strFile) > 0
Cnt = Cnt + 1
r = Cells(Rows.count, "A").End(xlUp).Row + 1
Open strSourcePath & strFile For Input As #1
Do Until EOF(1)
Line Input #1, strData
x = Split(strData, ",")
For c = 0 To UBound(x)
Cells(r, c + 1).Value = Trim(x(c))
Next c
r = r + 1
Loop
Close #1
Name strSourcePath & strFile As strDestPath & strFile
strFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then _
MsgBox "No CSV files were found...", vbExclamation
End Sub
Well it looks like you've got both of the pieces there. Your first subroutine saves a blank workbook called consol.xlsx.
Then, your second subroutine loops through the directory, opens each csv file, and copes it to some unspecified range.
What I would insert before your loop is:
Set wbkConsol = Workbooks.Open(thisWorkbook.path & "\Consol.xlsx")
Then, during your loop over the CSV files:
strFile = Dir(strSourcePath & "*.csv")
Do While Len(strFile) > 0
Cnt = Cnt + 1
r = Cells(Rows.count, "A").End(xlUp).Row + 1
Open strSourcePath & strFile For Input As #1
Do Until EOF(1)
Line Input #1, strData
' Set wshAdd = wbkConsol.Worksheets.Add() ' New ws in wbk
' wshAdd.Name = left(strFile, 31) ' First 31-chars of filename.
x = Split(strData, ",")
For c = 0 To UBound(x)
wshAdd.Cells(r, c + 1).Value = Trim(x(c))
Next c
r = r + 1
Loop
Close #1
Name strSourcePath & strFile As strDestPath & strFile
strFile = Dir()
Loop
As an added note: you could pass your workbook from your first sub to the second sub, by reference. That way, you won't have to open it up again. This would be by combining the button click into just a single command.
Sub1()
wbkConsol = workbooks.Add
Call sub2(wbkConsol)
End sub
This code extracts files with names like "M*", and I'd like it to also pull files with names like "X*". Can I simply set an OR condition on the filename parameter? Thanks for your advice!
Worksheets("PMNs").Range("A2:A500").Clear
Application.Calculation = xlManual
Dim Filename, Pathname As String
Dim wb As Workbook
Dim ws As Worksheet
Pathname = ActiveWorkbook.Path & "\"
Filename = Dir(Pathname & "M*.xlsm")
x = 1
Range("A1").Select
Do While Filename <> ""
x = x + 1
' MsgBox (Filename)
Windows("Resource Load Data_fy18.xlsm").Activate 'open data file
Sheets("PMNs").Select
ActiveCell(A & x).Value = Filename 'copy filename to next cell Ax
Filename = Dir()
Loop
Application.Calculation = xlAutomatic
Dim lastrow As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lastrow).Sort key1:=Range("A2:A" & lastrow), _
order1:=xlAscending, Header:=xlNo
End Sub
Slightly change the way you open the files:
Dim Filename as String, Pathname As String
Dim wb As Workbook
Dim ws As Worksheet
Pathname = ActiveWorkbook.Path & "\"
x = 1
Range("A1").Select
Dim StrFile As String
StrFile = Dir(Pathname)
Do While Len(StrFile) > 0
If (Left(StrFile, 1) = "M" Or Left(StrFile, 1) = "X") and right(StrFile,4) = "xlsm" Then
Debug.print(StrFile) ' prints the file name and extension
' Do stuff here!
End If
Filename = Dir
Loop
I have a code that converts each sheet of a spreadsheet into a txt file.
The code is working well, however given the big amount of exports (abuot 90 txt files) I'd like to seek advice on how to speed this code up.
This is my code:
Sub xlsxTotxt()
Dim i As Integer
Dim directory As String
Dim fname As String
Dim xWs As Worksheet
Dim xTextFile As String
Dim rdate As String
directory = ThisWorkbook.Sheets("Macro").Range("D576").Value
rdate = ThisWorkbook.Sheets("Macro").Range("E47").Value
i = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While ThisWorkbook.Sheets("Macro").Range("D577").Offset(i).Value <> ""
fname = Sheets("Macro").Range("D577").Offset(i).Value
Workbooks.Open (directory & fname)
For Each xWs In Workbooks(fname).Worksheets
xWs.Copy
xTextFile = directory & rdate & " - " & xWs.name & ".txt"
Application.ActiveWorkbook.SaveAs filename:=xTextFile, FileFormat:=xlText
Application.ActiveWorkbook.Saved = True
Application.ActiveWorkbook.Close
Next
Workbooks(fname).Close
i = i + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Thanks in advance for your help!
Instead of copying each sheet
Save ThisWorkBook
Select each worksheet
Save workbook as text - this only saves the select worksheet as text
Reopen original workbook
Close last text file
Sub xlsxTotxt()
Dim i As Integer
Dim directory As String
Dim fname As String
Dim xWs As Worksheet
Dim xTextFile As String
Dim rdate As String
Dim ThisFullName As String
ThisFullName = ThisWorkbook.FullName
ThisWorkbook.Save
directory = ThisWorkbook.Sheets("Macro").Range("D576").value
rdate = ThisWorkbook.Sheets("Macro").Range("E47").value
i = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While ThisWorkbook.Sheets("Macro").Range("D577").Offset(i).value ""
fname = Sheets("Macro").Range("D577").Offset(i).value
Workbooks.Open (directory & fname)
For Each xWs In Workbooks(fname).Worksheets
xWs.Select
xTextFile = directory & rdate & " - " & xWs.Name & ".txt"
ThisWorkbook.SaveAs Filename:=xTextFile, FileFormat:=xlText
Next
i = i + 1
Loop
Application.Workbooks.Open ThisFullName
ThisWorkbook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have multiple workbooks in the same layout. In the cell "I8" I have calculated a specific value that I want to compile from all workbooks.
Here is an example of my code:
Sub Code()
Dim file As String
Dim wbResults As Workbook
Dim myPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
myPath = "C:\Test\"
file = Dir$(myPath & "*.xls*")
While (Len(file) > 0)
Set wbResults = Workbooks.Open(Filename:=myPath & file, UpdateLinks:=0)
With wbResults.Worksheets(Split(file, ".")(0))
With .Range("I8")
.Formula = "=10^(D28+(I7*I2))"
End With
End With
wbResults.Close SaveChanges:=True
file = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I would like to add to this code and compile a list in another excel workbook where column A puts the name of the file of a workbook and column B puts the value of "I8" in that respective workbook.
Here is my answer:
Sub Code()
Dim file As String
Dim wbResults As Workbook
Dim myPath As String
myPath = "C:\Test\"
'---------------- Create a new workbook then save it ----------------
Dim WBSummary As Workbook
Set WBSummary = Excel.Application.Workbooks.Add
WBSummary.SaveAs myPath & "WBSummary.xls"
'--------------------------------------------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
file = Dir$(myPath & "*.xls*")
Dim i As Long 'To update row number in WBSummary
While (Len(file) > 0)
i = i + 1
If file <> "WBSummary.xls" Then
Set wbResults = Workbooks.Open(Filename:=myPath & file, UpdateLinks:=0)
With wbResults.Worksheets(Split(file, ".")(0))
With .Range("I8")
.Formula = "=10^(D28+(I7*I2))"
.Calculate 'To update value in "I8"
WBSummary.Worksheets(1).Cells(i, 1).Value = file
WBSummary.Worksheets(1).Cells(i, 2).Value = .Value
End With
End With
wbResults.Close SaveChanges:=True
End If
file = Dir
Wend
WBSummary.Close True 'Close and Save WBSummary
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub