TXT Dateien öffnen

Sub Makro32() With ActiveSheet.QueryTables.Add(Connection:= _ "TEXT;C:\Users\acer\Desktop\512801200\Einnahmen\report.txt", Destination:= _ Range("$A$1")) .CommandType = 0 .Name = "report" .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 = True .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Bearbeiten() Range("J4").Select ActiveCell.FormulaR1C1 = "MwSt-Satz" Range("J5").Select ActiveCell.FormulaR1C1 = _ "=IFERROR(IF(RC[-5]=""Artikelpreis"",(IF(LEFT(1)=""M"",""19%"",""7%"")),""""),"""")" Range("I5").Select Selection.End(xlDown).Select ActiveCell.Offset(0, 1).Select Range(Selection, Selection.End(xlUp)).Select Selection.FillDown Dim L As Long For L = 1 To Range("E65536").End(xlUp).Row If Cells(L, 5).Value = "Aktionsrabatt" Then Range("A1:J1").EntireColumn.Delete Exit Sub End If Next Columns("J:J").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim Ez As Long 'erste Zeile (hast Du vorgegeben) Dim Lz As Long 'letzte Zeile (wird ermittelt) Dim Spalte As String Spalte = "A" Ez = 4 'Vorgabe Lz = ActiveSheet.Cells(Rows.Count, Spalte).End(xlUp).Row 'ermitellt letzte Zeile ActiveSheet.Range(Spalte & Ez & ":K" & Lz).Select Selection.Sort Key1:=ActiveCell.Offset(0, 9), _ Order1:=xlDescending, _ DataOption1:=xlSortNormal, _ Key2:=ActiveCell.Offset(0, 2), _ Order2:=xlDescending, _ DataOption2:=xlSortNormal, _ Header:=xlYes, _ MatchCase:=False, _ Orientation:=xlTopToBottom Range("A2").Select Selection.End(xlDown).Select ActiveCell.Offset(2, 0).Select ActiveCell.FormulaR1C1 = "Gesamt" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "=SUM(R[-715]C[5]:R[999283]C[5])" ActiveCell.Offset(1, -1).Select ActiveCell.FormulaR1C1 = "Gebühren" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "=SUMIF(C[3],""Amazon-Gebühren"",C[5])" ActiveCell.Offset(1, -1).Select ActiveCell.FormulaR1C1 = "7%" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "=SUMIF(C[8],""7""%,C[5])" ActiveCell.Offset(1, -1).Select ActiveCell.FormulaR1C1 = "19%" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "=SUMIF(C[8],""19%"",C[5])" Cells.Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub

Sub Main() Dim strDateiname As String Dim wkbBook As Workbook Dim lngLastRowQ As Long Dim lngLastRowZ As Long Dim lngLastCol As Long Dim intCalc As Integer On Error GoTo Fin With Application .ScreenUpdating = False .AskToUpdateLinks = False .EnableEvents = False intCalc = .Calculation .Calculation = xlCalculationManual .DisplayAlerts = False End With 'strDateiname = Dir$(ThisWorkbook.Path & "\*.xls") strDateiname = Dir$(strPath & "*.xlsx") Do While strDateiname "" If strDateiname ThisWorkbook.Name Then Set wkbBook = Workbooks.Open(strPath & strDateiname) Call Bearbeiten wkbBook.Close True ' Oder True, wenn gespeichert werden soll Set wkbBook = Nothing End If strDateiname = Dir$() Loop Fin: Set wkbBook = Nothing With Application .ScreenUpdating = True .AskToUpdateLinks = True .EnableEvents = True .Calculation = intCalc .DisplayAlerts = True End With If Err.Number 0 Then MsgBox "Error: " & _ Err.Number & " " & Err.Description End Sub

Hallo Christoph,
die Einbindung des zusätzlichen Makros müßte etwa wie folgt erfolgen.
Es kann aber sein, dass das Laden der Daten aus der Textdatei irgendwie nicht schnell genug funktioniert. Deshalb das zusätzliche RefreshAll.

            Application.DisplayAlerts = False 'ggf. vorhandene Exceldatei _
wird überschrieben
wkbText.RefreshAll
Call Bearbeiten

Das Problem mit der Formel: ? Entweder wird die letzte Zeile nicht korrekt ermittelt oder vor dem Ersetzen der Formeln durch ihre Werte muss die Datei noch neu berechent werden
Application.Calculate
Ich hab mir dein Makro mal angesehen. Versuche es mal mit der nachfolgenden Variante.
Ein paar Spalten-Nummern muss du ggf. noch korrigieren. Bei vielen Select- und ActiveCell-Anweisungen verliert man schon mal den Überblick. Die Formeln werden noch nicht durch Werte erstzt. Die entsprechenden Zeilen sind noch als Kommentare enthalten
Gruß
Franz

Sub Bearbeiten()
Dim Zeile As Long
Dim L As Long, wks As Worksheet
Set wks = ActiveSheet
With wks
With .UsedRange
Zeile = .Row + .Rows.Count - 1
End With
.Range("J4").FormulaR1C1 = "MwSt-Satz"
'Formel in Spalte J
.Range(.Cells(5, 10), .Cells(Zeile, 10)).FormulaR1C1 = _
"=IFERROR(IF(RC[-5]=""Artikelpreis""," _
& "(IF(LEFT(RC[-7],1)=""M"",""19%"",""7%"")),""""),"""")"
For L = 1 To Zeile
If .Cells(L, 5).Value = "Aktionsrabatt" Then
.Range("A1:J1").EntireColumn.Delete
Exit Sub
End If
Next
With .Columns("J:J")
.Copy
'            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
Dim Ez As Long    'erste Zeile (hast Du vorgegeben)
Dim Lz As Long    'letzte Zeile (wird ermittelt)
Dim Spalte As Long
Spalte = 1    'Spalte A
Ez = 4        'Vorgabe
Lz = .Cells(.Rows.Count, Spalte).End(xlUp).Row  'ermitellt letzte Zeile
'Daten Spalten A bis K ab Zeile 4 sortieren nach Spalte J und C
With .Range(.Cells(Ez, Spalte), .Cells(Lz, 11))
.Sort _
Key1:=.Cells(1, 10), Order1:=xlDescending, DataOption1:=xlSortNormal, _
Key2:=.Cells(1, 3), Order2:=xlDescending, DataOption2:=xlSortNormal, _
Header:=xlYes, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With
.Cells(Lz + 2, 1).Value = "Gesamt"
.Cells(Lz + 2, 2).FormulaR1C1 = "=SUM(R" & (Ez + 1) & "C[5]:R[-2]C[5])"
.Cells(Lz + 3, 1).Value = "Gebühren"
.Cells(Lz + 3, 2).FormulaR1C1 = "=SUMIF(C[3],""Amazon-Gebühren"",C[5])"
.Cells(Lz + 4, 1).Value = "7%"
.Cells(Lz + 4, 2).FormulaR1C1 = "=SUMIF(C[8],""7""%,C[5])"
.Cells(Lz + 5, 1).Value = "19%"
.Cells(Lz + 5, 2).FormulaR1C1 = "=SUMIF(C[8],""19%"",C[5])"
'Zellen mit Summenformeln durch Werte ersetzen
With .Range(.Cells(Lz + 2, 2), .Cells(Lz + 5, 2))
.Calculate
'.Value = .Value
End With
End With
End Sub

'Auswahl-Dialog für Ordner anzeigen With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Bitte Verzeichnis/Ordner mit den report-Text-Dateien auswählen" If .Show = -1 Then strPfad_txt = .SelectedItems(1) Else GoTo Beenden End If End With

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

TXT Dateien öffnen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread