Spalten umkopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Spalten umkopieren
von: Heinz
Geschrieben am: 20.04.2015 15:36:33

Hallo,
ich habe ein Problem beim umsortieren von Tabulator getrennten Werten. Leider kann ich kein VBA (außer Makro Recorder). Vielleicht kann mir hier jemand helfen?
Mein Messfile sieht folgendermaßen aus:
Spalte A + B Koordinaten, Spalte C Wellenlänge und Spalte D Intensitäten
Bei mehreren Messungen werden die verschiedenen Spektren mit den entsprechenden Wellenlängen untereinander geschrieben. Mein Auswertetool braucht die Daten aber in einem anderen Format. D.h. Spalte A+B fallen weg, die Zeilen aus C die zum ersten Spektrum gehören werden in Spalte A kopiert und entsprechend die Intensitäten des ersten Spektrums aus Spalte D in Spalte B. Dann werden die Intensitäten des zweiten Spektrums in Spalte C kopiert usw.
Als Beispiel - vorher:
1 0 23 50
1 0 24 52
1 0 25 51
1 0 26 50
1 1 23 20
1 1 24 22
1 1 25 21
1 1 26 20
nachher:
23 50 20
24 52 22
25 51 21
26 50 20
Über Hilfe freue ich mich sehr.

Bild

Betrifft: AW: Spalten umkopieren
von: UweD
Geschrieben am: 20.04.2015 16:06:52
Hallo
so ??

Sub Spektrum()
    On Error GoTo Fehler
    Dim i&, j%, LR&
    Application.ScreenUpdating = False
    
    With ActiveWorkbook.Sheets("Tabelle1")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("C:C") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange Range("A:D")
        .Sort.Header = xlNo
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
        .Columns("A:B").Delete xlLeft
        
        LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte jetzt A
        j = 3
        For i = LR To 2 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                .Cells(i - 1, j) = .Cells(i, 2)
                .Rows(i).Delete xlUp
                j = j + 1
            Else
                j = 3
            End If
        
        Next
    End With
    Err.Clear
Fehler:
        If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _
Clear
End Sub

Gruß UweD

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: UweD
Geschrieben am: 20.04.2015 16:18:21
Hi nochmal
für mehr als 2 Einträge folgender Aufbau

Sub Spektrum()
    On Error GoTo Fehler
    Dim i&, j%, LR&
    Application.ScreenUpdating = False
    
    With ActiveWorkbook.Sheets("Tabelle1")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("C:C") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange Range("A:D")
        .Sort.Header = xlNo
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
        .Columns("A:B").Delete xlLeft
        
        LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte jetzt A
        j = 3
        For i = LR To 2 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                .Range(.Cells(i, 2), .Cells(i, j)).Copy .Cells(i - 1, 3)
                .Rows(i).Delete xlUp
                j = j + 1
            Else
                j = 3
            End If
        
        Next
    End With
    Err.Clear
Fehler:
        If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _
Clear
End Sub


Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 20.04.2015 20:14:20
Hallo UweD,
vielen Dank für die schnelle Antwort + das Skript! Ich habe tatsächlich sehr viele Spektren untereinander stehen. Bin schon gespannt das Skript morgen auf der Arbeit auszuprobieren!
Gruß Heinz

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 21.04.2015 10:24:04
Hallo UweD,
perfekt! Es funktioniert genauso wie ich es benötige. Vielen Dank!
Gruß Heinz

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 21.04.2015 16:00:36
Hallo nocheinmal,
das Skript von UweD leistet fantastische Dienste. Da es allerdings sehr lange dauert bis es feritg ist (die Dateien sind immer sehr groß) wäre es sehr hilfreich, wenn es alle Dateien in einem Ordner nacheinander konvertieren kann. D.h. die erste .txt Datei in Excel oeffnen, umformatieren mit dem selben Namen als .dat Datei speichern und schliessen und dann die nächste Datei oeffnen usw. Die Original Dateien müssen aber erhalten bleiben.
Kann mir dabei bitte noch jemand helfen?

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Jürgen V.
Geschrieben am: 21.04.2015 21:45:04
Hallo Heinz,
wenn es darum geht, jeweils eine Textdatei in eine Textdatei zu konvertieren (was Deiner ursprünglichen Frage nicht so deutlich zu entnehmen war), lässt sich der Code wahrscheinlich noch optimieren und natürlich so erweitern, dass alle Dateien eines Verzeichnisses konvertiert wird.
Hast Du die Möglichkeit, eine Beispieldatei hochzuladen?
Gruß, Jürgen

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 21.04.2015 22:49:54
Hallo Jürgen,
danke für Deine Antwort. Eine Bsp.-Datei kann ich erst morgen hochladen. Ich möchte die Daten in meinen Ascii-Dateien umsortieren. Konkret heißt das: ich möchte meine Messdatei mit .txt Dateiendung öffnen, umsortieren und mit der Dateiendung .dat abspeichern. Das ganze sollte mit allen txt. Dateien passieren, die in einem ausgewählten Ordner liegen. Das umsortieren an sich funktioniert mit dem Skript von UweD schon sehr gut.

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 22.04.2015 08:55:45
Hallo Jürgen,
hier sind die Bsp-Dateien. Die .txt Datei ist die Messdatei und die .dat Datei ist die mit dem Skript umformatierte. In meinem Messordner liegen viele .txt Dateien.
Gruß Heinz
https://www.herber.de/bbs/user/97218.txt
https://www.herber.de/bbs/user/97219.dat

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: UweD
Geschrieben am: 22.04.2015 10:54:27
Hallo nochmal.
hab das noch drumherumgebaut.
In deiner .dat Musterdatei ist noch viel "Müll" hinter den eigendlichen Daten. Diese Leerzeilen hab ich weggelassen :-)

Sub Spektrum()
    On Error GoTo Fehler
    Dim Dlg As FileDialog
    Dim Pfad, Ext1$, Ext2$, Datei$
    Dim i&, j%, LR&
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
    Dlg.InitialFileName = "C:\Temp\" 'Start-Verzeichnis
    If Dlg.Show Then
        Pfad = Dlg.SelectedItems(1)
        Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\")
        Ext1 = ".txt": Ext2 = ".dat"
        Datei = Dir(Pfad & "*" & Ext1)
        Do While Len(Datei) > 0
            Workbooks.OpenText FileName:=Pfad & Datei, Origin:=xlMSDOS, StartRow:=1, _
                DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, _
                Space:=False, Other:=False, FieldInfo:=Array(Array(1, 9), Array(2, 9), _
                Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
            
            Application.ScreenUpdating = False
            With ActiveWorkbook.Sheets(1)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A:A") _
                    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SetRange Range("A:B")
                .Sort.Header = xlNo
                .Sort.MatchCase = False
                .Sort.Orientation = xlTopToBottom
                .Sort.SortMethod = xlPinYin
                .Sort.Apply
                LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte jetzt A
                j = 3
                For i = LR To 2 Step -1
                    If .Cells(i, 1) = .Cells(i - 1, 1) Then
                        .Range(.Cells(i, 2), .Cells(i, j)).Copy .Cells(i - 1, 3)
                        .Rows(i).Delete xlUp
                        j = j + 1
                    Else
                        j = 3
                    End If
                Next
            End With
            ActiveWorkbook.SaveAs FileName:=Pfad & Replace(Datei, Ext1, Ext2), _
                FileFormat:=xlText, CreateBackup:=False
            ActiveWindow.Close SaveChanges:=False
            Datei = Dir() ' nächste Datei
        Loop
    End If
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 22.04.2015 13:18:08
Hallo UweD,
vielen Dank für die tolle Hilfe! Das Skript funktioniert fehlerfrei! Ein neues Problem ist mir eben erst aufgefallen. In meiner Messdatei sind Spalte A + B Ortskoordinaten und aufsteigend sortiert. Für meine Auswertung müssen die Spektren aber genau andersherum sortiert sein, d.h. die .txt Datei muss erst absteigend nach Spalte A und in zweiter Rangfolge absteigend nach Spalte B sortiert werden. Danach soll dann alles so wie in dem Skript weiterlaufen.
Wenn Du das auch noch für mich einfügen kannst bin ich sehr froh. Ich hoffe, ich bitte mittlerweile nicht um zu viel.
LG Heinz

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: UweD
Geschrieben am: 22.04.2015 14:21:57
Kein Problem...

Sub Spektrum()
    On Error GoTo Fehler
    Dim Dlg As FileDialog
    Dim Pfad, Ext1$, Ext2$, Datei$
    Dim i&, j%, LR&
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
    Dlg.InitialFileName = "C:\Temp\" 'Start-Verzeichnis
    If Dlg.Show Then
        Pfad = Dlg.SelectedItems(1)
        Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\")
        Ext1 = ".txt": Ext2 = ".dat"
        Datei = Dir(Pfad & "*" & Ext1)
        Do While Len(Datei) > 0
            Workbooks.OpenText FileName:=Pfad & Datei, Origin:=xlMSDOS, StartRow:=1, _
                DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, _
                Space:=False, Other:=False, FieldInfo:=Array(Array(1, 9), Array(2, 9), _
                Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
            
            Application.ScreenUpdating = False
            With ActiveWorkbook.Sheets(1)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A:A"), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                .Sort.SortFields.Add Key:=Range("B:B"), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                .Sort.SetRange Range("A:B")
                .Sort.Header = xlNo
                .Sort.MatchCase = False
                .Sort.Orientation = xlTopToBottom
                .Sort.SortMethod = xlPinYin
                .Sort.Apply
                LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte jetzt A
                j = 3
                For i = LR To 2 Step -1
                    If .Cells(i, 1) = .Cells(i - 1, 1) Then
                        .Range(.Cells(i, 2), .Cells(i, j)).Copy .Cells(i - 1, 3)
                        .Rows(i).Delete xlUp
                        j = j + 1
                    Else
                        j = 3
                    End If
                Next
            End With
            ActiveWorkbook.SaveAs FileName:=Pfad & Replace(Datei, Ext1, Ext2), _
                FileFormat:=xlText, CreateBackup:=False
            ActiveWindow.Close SaveChanges:=False
            Datei = Dir() ' nächste Datei
        Loop
    End If
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Gruß UweD

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 22.04.2015 16:48:42
Hallo UweD,
danke für Deine Unterstützung. Mit dem neuen Skript klappt die Sortierung noch nicht so ganz, ich lade mal drei Dateien hoch eine "Messdatei", eine mit der alten Version umgewandelte und eine mit der neuen Version des Skriptes umgewandelte.
Für mich wäre es auch wichtig wenn Spalte C (Wellenlänge) aufsteigend sortiert bleibt.
GRüße
Heinz
https://www.herber.de/bbs/user/97243.txt
https://www.herber.de/bbs/user/97244.dat
https://www.herber.de/bbs/user/97245.dat

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: UweD
Geschrieben am: 23.04.2015 08:41:21
Hi
Wie denn jetzt??
Sortierung sollte nach deiner letzten Info
- Spalte A abwärts sein
- Spalte B auch abwärts
das wird hierdurch geregelt:
wenn man nur nach A abwärts sortiert (2.Sortierung 'auskommentiert) dann wäre es so..
Userbild

 ABCDEFGHIJKLMNOP
122s1s2s3s4s5s6s7s8s9s10s11s12s13s14s15
221s1s2s3s4s5s6s7s8s9s10s11s12s13s14s15
320s1s2s3s4s5s6s7s8s9s10s11s12s13s14s15




Gruß UweD

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 23.04.2015 08:55:25
Hallo UweD,
ich habe das nicht eindeutig formuliert. Die gewünschte Sortierung bezog sich auf die noch-nicht umformatierte Datei (also Messdatei). Wenn die Sortierung abgeschlossen ist soll der Rest von Deinem Skript so wie vorher auch greifen. Ich hätte am Ende also gerne vollegende Sortierung:
A B C D ...
20 S20 S19 S18 ... S1
21 S20 S19 S18 ... S1
22 S20 S19 S18 ... S1
Gruß Heinz

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: UweD
Geschrieben am: 23.04.2015 10:30:07
Hallo
Erste Sortierung also aufsteigend

.Sort.SortFields.Add Key:=Range("A:A"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Zweite Sortierung absteigend
.Sort.SortFields.Add Key:=Range("B:B"), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

Das Problem ist der Inhalt der Daten in Spalte B.
Jetzt ist das Text und keine Zahl mehr..
Dann ist die Sortierreihenfolge eben so: S4, S3, S20, S2, S19
97243
 AB
120s9
220s8
320s7
420s6
520s5
620s4
720s3
820s20
920s2
1020s19
1120s18
1220s17
1320s16
1420s15
1520s14
1620s13
1720s12
1820s11
1920s10
2020s1
2121s9
2221s8
2321s7




Kommen denn tatsächlich Solche Texte vor??
Gib doch mal ORIGINALDATEN an. Evtl kann man ja erst normieren...
z.B. S2 zu S02 machen etc.
Gruß UweD

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 23.04.2015 12:58:01
Hallo UweD,
also ich habe jetzt eine Original-Datei und die daraus erzeugte, umformatierte Datei hochgeladen. Nach intensivem Vergleichen der beiden Dateien habe ich festgestellt, dass die Spektren beim umsortieren durcheinander geraten, d.h. gemsicht werden. Konkret stimmt jede zweite Zeile in den Spektren nicht mehr. Blicke da im Moment nicht mehr durch. Kannst Du mir weiter helfen?
https://www.herber.de/bbs/user/97263.txt
https://www.herber.de/bbs/user/97264.dat

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 23.04.2015 13:26:14
Was mir noch aufgefallen ist, in der .dat Datei stehen an ein paar Stellen Daten im Format "Dez 55" usw. (siehe letzte hochgeladene Datei) kopiere ich die Daten nach excel sind das aber auch wieder Zahlen.

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: UweD
Geschrieben am: 23.04.2015 15:33:33
hallo nochmal
Das Dez steht schon in der Txt-Datei drin.
Ich vermute, DEZ 55 war ursprünglich 12.55
- - -
Ich gehe jetzt davon aus, dass der Punkt als Dezimaltrennzeichen angesehen werden soll...
Das brauche ich zum größenmäßigen sortieren. Also lese die die Daten mit Komma anstelle Punkt ein.
Kann das nachher so bleiben?

Sub Spektrum()
    On Error GoTo Fehler
    Dim Dlg As FileDialog
    Dim Pfad, Ext1$, Ext2$, Datei$
    Dim i&, j%, LR&
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
    Dlg.InitialFileName = "C:\Temp\" 'Start-Verzeichnis
    If Dlg.Show Then
        Pfad = Dlg.SelectedItems(1)
        Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\")
        Ext1 = ".txt": Ext2 = ".dat"
        Datei = Dir(Pfad & "*" & Ext1)
        Do While Len(Datei) > 0
        
             Workbooks.OpenText FileName:=Pfad & Datei, Origin:=xlMSDOS, StartRow:=1, _
                DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, _
                Space:=False, Other:=False, FieldInfo:=Array(Array(1, 9), Array(2, 9), _
                Array(3, 1), Array(4, 1)), DecimalSeparator:=".", ThousandsSeparator:=",", _
                TrailingMinusNumbers:=True
           
            Application.ScreenUpdating = False
            With ActiveWorkbook.Sheets(1)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A:A"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SortFields.Add Key:=Range("B:B"), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                .Sort.SetRange Range("A:B")
                .Sort.Header = xlNo
                .Sort.MatchCase = False
                .Sort.Orientation = xlTopToBottom
                .Sort.SortMethod = xlPinYin
                .Sort.Apply
                LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte jetzt A
                j = 3
                For i = LR To 2 Step -1
                    If .Cells(i, 1) = .Cells(i - 1, 1) Then
                        .Range(.Cells(i, 2), .Cells(i, j)).Copy .Cells(i - 1, 3)
                        .Rows(i).Delete xlUp
                        j = j + 1
                    Else
                        j = 3
                    End If
                Next
            End With
            ActiveWorkbook.SaveAs FileName:=Pfad & Replace(Datei, Ext1, Ext2), _
                FileFormat:=xlText, CreateBackup:=False
            ActiveWindow.Close SaveChanges:=False
            Datei = Dir() ' nächste Datei
        Loop
    End If
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Gruß UweD


Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 23.04.2015 15:40:43
Hallo UweD,
ja stimmt die Daten haben einen Punkt als Dezimaltrennzeichen, den benoetige ich auch in der ausgewerteten Datei.
Das mit dem Datum kann gut sein, habe gerade nach gesehen, die anderen DAteien haben das nicht. Werde das Skript erst morgen testen koennen, wegen anderen Terminen.
Vielen DAnk!!!
Heinz

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: UweD
Geschrieben am: 23.04.2015 17:01:34
So, ich hoffe jetzt klapp es
Ich habe in der Txt die Datumangaben (nicht nur Dez...) ersetzt und damit weiterprobiert.
- Vor dem Öffnen der Datei schalte ich Excel um ( Komma und Punkt werden andersherum gehandelt)
- Dann wird die TXT geöffnet
- Anschließend mit den Punkten als Dezimattrenner sortiert.
- verarbeitet...
- abgespeichert
- und zum Schluss Excel wieder zurückgestellt.

Sub Spektrum()
    On Error GoTo Fehler
    Dim Dlg As FileDialog
    Dim Pfad, Ext1$, Ext2$, Datei$
    Dim i&, j%, LR&
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
    Dlg.InitialFileName = "C:\Temp\" 'Start-Verzeichnis
    If Dlg.Show Then
        Pfad = Dlg.SelectedItems(1)
        Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\")
        Ext1 = ".txt": Ext2 = ".dat"
        Datei = Dir(Pfad & "*" & Ext1)
        
        With Application
            .DecimalSeparator = "."
            .ThousandsSeparator = ","
            .UseSystemSeparators = False
        End With
        
        
        Do While Len(Datei) > 0
        
             Workbooks.OpenText FileName:=Pfad & Datei, Origin:=xlMSDOS, StartRow:=1, _
                DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, _
                Space:=False, Other:=False, FieldInfo:=Array(Array(1, 9), Array(2, 9), _
                Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
           
            Application.ScreenUpdating = False
            With ActiveWorkbook.Sheets(1)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A:A"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SortFields.Add Key:=Range("B:B"), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                .Sort.SetRange Range("A:B")
                .Sort.Header = xlNo
                .Sort.MatchCase = False
                .Sort.Orientation = xlTopToBottom
                .Sort.SortMethod = xlPinYin
                .Sort.Apply
                LR = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte jetzt A
                j = 3
                For i = LR To 2 Step -1
                    If .Cells(i, 1) = .Cells(i - 1, 1) Then
                        .Range(.Cells(i, 2), .Cells(i, j)).Copy .Cells(i - 1, 3)
                        .Rows(i).Delete xlUp
                        j = j + 1
                    Else
                        j = 3
                    End If
                Next
            End With
            ActiveWorkbook.SaveAs FileName:=Pfad & Replace(Datei, Ext1, Ext2), _
                FileFormat:=xlText, CreateBackup:=False
            ActiveWindow.Close SaveChanges:=False
            Datei = Dir() ' nächste Datei
        Loop
    End If
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = True
    End With
End Sub
Gruß UweD

Bild

Betrifft: AW: Spalten umkopieren >> Update
von: Heinz
Geschrieben am: 24.04.2015 08:09:10
Hallo UweD,
vielen Dank nochmals für Deine Mühe! Excel ist bei mir immer auf Punkt als Dezimaltrennzeichen eingestellt, Tausendertrennzeichen habe ich keines eingestellt. Die neue Version funktioniert leider auch nicht. Wenn ich die Spektren nachher plotte sind sie nicht vergleichbar mit denen von dem "alten" Skript, das ich überprüft hatte. Ich werde jetzt einfach das alte Skript nutzen und die ausgewerteten Daten umsortieren, das ist für mich übersichtlicher.
Vielen Dank für Deine Hilfe.
Gruß Heinz

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Spalten umkopieren"