Jag har satt ihop ifrån lite olika sites en funktion för att flytta cvs-fil information in i en excell-fil. Det fungerade kanon i fredags men nu så vägrar det att fungera och jag har inte gjort någon förändring i koden. Är där något annat som kan ha hänt vet inte vad jag skall leta? Det spontana jag ser är att dir-kommandot listar per default det som finns i aktuell katalog. Kan filerna ligga i en annan mapp? I övrigt, får du felmeddelande eller vad händer eller inte händer? Filerna ligger i samma katalog. Det jag upptäkte vara att om jag öppnade filen ifrån excel istället för att dubbel klicka i utforskaren fungerade allt, så jag ändrade koden till: Det finns ett kommando som jag tror heter curdir som kan användas för att peka ut den katalog som Excel startas från. Det kan var så att currwb.path skiljer sig från den katalog du står i. Denna delen verkar fungera bra nu Ta bort Refresh gör ingen skillnad.Vba excel Dir function har lagt av
Denna biten är inte min kod utan hämtad ifrån ett forum och har fungerat bra under hela fredagen när jag arbetade med den.
'Start subben för att göra alla funktioner
Sub ImportAllCSV()
Dim FName As Variant, R As Long
R = 1
FName = Dir("*.csv")
Do While FName <> ""
ImportCsvFile FName, ActiveSheet.Cells(R, 1)
R = ActiveSheet.UsedRange.Rows.Count + 1
FName = Dir
Loop
End Sub
' Sub för att inportera csv fil info till blad med namn från filnamnet
Sub ImportCsvFile(FileName As Variant, Position As Range)
Dim newString As String
Dim char As Variant
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & FileName _
, Destination:=Range("$A$1"))
.Name = "A00-40---1-D02------ Klar_allt"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ";"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
' det som är in kopierat några kolumner tas bort
Columns("C:I").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
newString = Right(FileName, 25)
'fixar till bladnamnet
For Each char In Split(SpecialCharacters, ",")
newString = Replace(newString, char, "")
Next
ActiveSheet.Name = Left(newString, Len(newString) - 3)
End Sub
Sv: Vba excel Dir function har lagt av
Hälsningar Pelle Sv:Vba excel Dir function har lagt av
'Start subben för att göra alla funktioner
Sub ImportAllCSV()
Dim FName As Variant, R As Long
Application.ScreenUpdating = False
R = 1
Set CurrWB = Workbooks("Bok1.xlsm")
directory = CurrWB.Path
FName = Dir(directory & "\" & "*.csv")
Do While FName <> ""
ImportCsvFile FName, ActiveSheet.Cells(R, 1)
R = ActiveSheet.UsedRange.Rows.Count + 1
FName = Dir
Loop
Call KopieraUnikaRaderBlad
Call RaderaLine
Call SammanStall
Call SidforNummer
Call KollaFlyttaData
'Call RäknaData
Application.ScreenUpdating = True
End Sub
' Sub för att inportera csv fil info till blad med namn från filnamnet
Sub ImportCsvFile(FileName As Variant, Position As Range)
Dim newString As String
Dim char As Variant
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & FileName _
, Destination:=Range("$A$1"))
.Name = "A00-40---1-D02------ Klar_allt" 'vet inte vad den här linjen gör verkar som inget
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ";"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
' det som är in kopierat några kolumner tas bort
Columns("C:I").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
newString = Right(FileName, 25)
'fixar till bladnamnet
For Each char In Split(SpecialCharacters, ",")
newString = Replace(newString, char, "")
Next
ActiveSheet.Name = Left(newString, Len(newString) - 3)
End Sub
Men med denna kod så stannar vid .Refresh BackgroundQuery:=False
och jag får felmeddelandet "Kör fel nr 1004: det går inte att hitta textfilen för att uppdatera detta externa datområde. Kontrollera att filen inte flyttats eller bytt namn och försök att uppdatera på nytt".
Så det jag tror är att excel inte rätt koppling till filen/mappen som filerna finns i när man öppnar ifrån utforskaren, men får rätt koppling när man öppnar innen ifrån excel. Frågan är hur man fixar det?
Sv: Vba excel Dir function har lagt av
Testa sånt genom att kasta in magbox för att se vad du har för värden när loopen körs, ex:
directory = CurrWB.Path
FName = Dir(directory & "\" & "*.csv")
magbox(fname)
/Pelle
Sv:Vba excel Dir function har lagt av
'Start subben för att göra alla funktioner
Sub ImportAllCSV()
Dim FName As Variant, R As Long
Application.ScreenUpdating = False
R = 1
Set CurrWB = Workbooks("Bok1.xlsm")
directory = CurrWB.Path
FName = Dir(directory & "\" & "*.csv")
MsgBox directory & " och " & FName
Do While FName <> ""
ImportCsvFile FName, ActiveSheet.Cells(R, 1)
R = ActiveSheet.UsedRange.Rows.Count + 1
FName = Dir
Loop
Call KopieraUnikaRaderBlad
Call RaderaLine
Call SammanStall
Call SidforNummer
Call KollaFlyttaData
'Call RäknaData
Application.ScreenUpdating = True
End Sub
Det är den andra delen som jag nu inte får till att fungera. Som jag skrev i tidigare.
Sv:Vba excel Dir function har lagt av
Men jag har hittat svaret.
Den första Sub’n är lösningen att sätta path till Dir funktionen
Set CurrWB = Workbooks("Bok1.xlsm")
directory = CurrWB.Path & "\"
FName = Dir(directory & "*.csv")
Do While FName <> ""
Den andra Sub’n så hittade jag en referens till hur man bygger en Connection och där var med file path.
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & directory & FileName _
, Destination:=Range("$A$1"))
Här är den färdiga programeringen
'Start subben för att göra alla funktioner
Sub ImportAllCSV()
Dim FName As Variant, R As Long
Application.ScreenUpdating = False
R = 1
Set CurrWB = Workbooks("Bok1.xlsm")
directory = CurrWB.Path & "\"
FName = Dir(directory & "*.csv")
Do While FName <> ""
ImportCsvFile FName, ActiveSheet.Cells(R, 1), directory
R = ActiveSheet.UsedRange.Rows.Count + 1
FName = Dir
Loop
Call KopieraUnikaRaderBlad
Call RaderaLine
Call SammanStall
Call SidforNummer
Call KollaFlyttaData
'Call RäknaData
Application.ScreenUpdating = True
End Sub
' Sub för att inportera csv fil info till blad med namn från filnamnet
Sub ImportCsvFile(FileName As Variant, Position As Range, directory As Variant)
Dim newString As String
Dim char As Variant
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & directory & FileName _
, Destination:=Range("$A$1"))
.Name = "A00-40---1-D02------ Klar_allt" 'vet inte vad den här linjen gör verkar som inget
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ";"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
.WorkbookConnection.Delete
End With
' det som är in kopierat några kolumner tas bort
Columns("C:I").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
newString = Right(FileName, 25)
'fixar till bladnamnet
For Each char In Split(SpecialCharacters, ",")
newString = Replace(newString, char, "")
Next
ActiveSheet.Name = Left(newString, Len(newString) - 3)
End Sub