PDA

View Full Version : Type Mismatch error because macro only applicable to .xls - files and not .csv



Nico45
11-24-2014, 08:16 AM
Hello all,

I'm new to this forum so I'd like to quickly introduce myself: I'm a bloody beginner in VBA but have to get together a code to solve the below stated problem: thus, I'm seeking help of you experts :) ... Of course, I've searched the forum before but none of what I've found matches my specific problem.

The macro opens all Excel files in the source folder, adjusts a couple of values in those files and then moves the files to another designated folder.
Everything works great but only as long as there are only .xls files in the source folder. However, I recently realized that the source folder only contains .csv files instead of .xls files.


Option Explicit

Sub doTheMagic()

Dim sSrcDir As String
Dim sTargetDir As String
Dim aSrcFiles() As String
Dim cur_file As String
Dim src_value As String
Dim i As Long

sSrcDir = getSrcDir()
sTargetDir = getTargetDir()

aSrcFiles = readSourceFiles(sSrcDir)

If Len(Join(aSrcFiles)) = 0 Then
MsgBox "Das Quellverzeichnis ist leer!"
Exit Sub
End If

For i = 0 To UBound(aSrcFiles) - 1
cur_file = aSrcFiles(i)
src_value = readValueFromExternalFile(sSrcDir, cur_file, "U2")

Dim WbDatei As Workbook
Set WbDatei = Workbooks.Open(sSrcDir & cur_file, ReadOnly:=False)

If src_value = "big" Then
' write values to file
WbDatei.Sheets("Tabelle1").Range("U2").value = "small"
WbDatei.Sheets("Tabelle1").Range("T2").value = "smaller"

Else
WbDatei.Sheets("Tabelle1").Range("U2").value = "big"
WbDatei.Sheets("Tabelle1").Range("T2").value = "bigger"

End If

WbDatei.Save
WbDatei.Close

Call moveFile(sSrcDir & "\" & cur_file, sTargetDir & "\" & cur_file)

Next i
End Sub

Private Function GetValue(pfad, datei, blatt, zelle)
Dim arg As String

If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
If Dir(pfad & datei) = "" Then
GetValue = "datei Not Found"
Exit Function
End If

arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(zelle).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)

End Function


Private Function readValueFromExternalFile(sPath, sFile, sCell)

Dim blatt As String
blatt = "Tabelle1"
readValueFromExternalFile = (GetValue(sPath, sFile, blatt, sCell))

End Function

Private Function readSourceFiles(ByVal sPath As String) As String()
Dim sFile As String, sPattern As String
Dim sFileList As String

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sPattern = "*.xl*"
sFile = Dir(sPath & sPattern)
Do Until sFile = ""
sFileList = sFileList & sFile & ","
sFile = Dir()
Loop

readSourceFiles = Split(sFileList, ",")

End Function

Private Function getSrcDir() As String
getSrcDir = Worksheets("config").Range("b2").value
End Function

Private Function getTargetDir() As String
getTargetDir = Worksheets("config").Range("b3").value
End Function

Private Sub moveFile(sSrc As String, sTarget As String)
Name sSrc As sTarget
End Sub

However, simply changing


sPattern = "*.xl*"
to


sPattern = "*.cs*"

doesn't do the trick.

Does anybody know how the below code needs to be adjusted in order to work with .csv files?

Thanks a lot!!!

Nico

Paul_Hossler
11-24-2014, 01:49 PM
Not elegant and not tested




Private Function readSourceFiles(ByVal sPath As String) As String()
Dim sFile As String, sPattern As String
Dim sFileList As String

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sPattern = "*.xl*"
sFile = Dir(sPath & sPattern)
Do Until sFile = ""
sFileList = sFileList & sFile & ","
sFile = Dir()
Loop

sPattern = "*.cs*"
sFile = Dir(sPath & sPattern)
Do Until sFile = ""
sFileList = sFileList & sFile & ","
sFile = Dir()
Loop


readSourceFiles = Split(sFileList, ",")

End Function

Nico45
11-25-2014, 08:46 AM
Hi Paul,

thx for this.
Unfortunately it leads to the same error message. From my recent research, the problem is likely to be linked to the fact that CSV files are just comma seperated text files. That's why it doesn't work the same way as with xls files. From what I've read, the csv file needs to be read into an array. The two cells that need to be changed however, have to be identified in the array before they are changed. After that, the array has to be changed back to the CSV file as it was before.

I found a code that would cover part of the transformation but probably not all of it:


Sub Csvreadtest()

Dim flname
Dim FileNum As Integer
Dim Counter As Long, maxrow As Long
Dim WorkResult As String
Dim ws As Worksheet
Dim i As Long

maxrow = Cells.Rows.Count
MsgBox "Select Data File"
flname = Application.GetOpenFilename(FileFilter:= _
"Text file (*.prn;*.txt;*.csv;*.dat),*.prn;*.txt;*.csv;*.dat" _
, MultiSelect:=False)

If VarType(flname) = vbBoolean Then
Exit Sub
End If

Application.ScreenUpdating = False
Application.EnableEvents = False

Set ws = ActiveWorkbook.ActiveSheet

Counter = Cells(Cells.Rows.Count, "A").End(xlUp).Row

If Counter <> 1 Then
Counter = Counter + 1
End If

FileNum = FreeFile()

Open flname For Input As #FileNum

Do While Not EOF(FileNum)
If Counter > maxrow Then
MsgBox "Reached max row"
Exit Sub
End If
Line Input #FileNum, WorkResult
Cells(Counter, "A") = WorkResult
Application.DisplayAlerts = False
Cells(Counter, "A").TextToColumns Destination:= _
Cells(Counter, "A"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=True, Space:=False, _
Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 4)) '<==change here
Counter = Counter + 1
Loop
Close #FileNum

ws.Columns("B").NumberFormat = "dd/mm/yyyy" '<==change here

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub



So thanks to all for further input

snb
11-25-2014, 09:46 AM
Keep it 'Einfach'


Sub M_snb()
c00="G:\OF\"

sn=filter(split(createobject("wscript.shell").exec("cmd /c Dir """ & c00 & "*.csv"" /b/a/s").stdout.readall,vbcrlf),".")

for j=0 to ubound(sn)
with getobject(it)
.Sheets(1).Range("T2").resize(,2).value = iif(.Sheets(1).Range("U2").value="big",array("small","smaller"),array("big","bigger"))
.close -1
end with
next
End Sub