Spalte kopieren

Forumthread: Spalte kopieren

Spalte kopieren

23.05.2013 19:14:54

Chris

Hallo vbaler
Ich möchte im sheet BASIS von f aus jede 6 Spalte kopieren
Also F L R USW, bis EN, Anfangszeiten ist jeweils Nr 16, also F16, L16 bis jeweils used Range.
Dann sollen die Werte (Datum) im gleichen sheet Range EZ untereinander geschrieben werden, ohne das leerzeichen dazwischen sind.
Bin für jede HIlfe dankbar.
Chris

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Spalte kopieren

23.05.2013 20:21:17

steffen
AW: Spalte kopieren

23.05.2013 20:24:05

fcs

AW: Spalte kopieren

23.05.2013 20:21:17

steffen

so könnte das gewünschte klappen:

Sub Kopieren_()
Dim a As Byte
Dim b As Integer
Dim lRowa As Integer
Dim lRowEZ As Integer
Application.ScreenUpdating = False
For a = 1 To 24 'jede 6.Spalte F bis EN(6*24=144 entspricht Spalte EN)
lRowa = Cells(Rows.Count, a * 6).End(xlUp).Row 'letzte Zeile der jeweiligen Spalte  _
ermitteln
For b = 16 To lRowa 'von Zeile 16 aufwärts alle gefüllten Zellen auslesen
lRowEZ = Cells(Rows.Count, 156).End(xlUp).Row 'letzte Zeile in Zielspalte ermitteln
Cells(lRowEZ + 1, 156) = Cells(b, a * 6) 'Daten aus Urprungsspalte nach Zielspalte ü _
bergeben
Next b
Next a
Columns("EZ:EZ").NumberFormat = "m/d/yyyy" 'Zielspalte als Datum formatieren
Range("EZ1").Delete Shift:=xlUp 'obere leere Zelle entfernen
Application.ScreenUpdating = True
End Sub

AW: Spalte kopieren

23.05.2013 20:24:05

fcs

Hallo Chris,
geht etwa so.
Gruß
Franz

Sub Test()
Dim wks As Worksheet, lngSpalte As Long, lngZeile As Long, lngLast As Long
Dim StatusCalc As Long
Set wks = Worksheets("BASIS")
'Makrobremsem lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wks
'Daten kopieren
lngZeile = 16
For lngSpalte = 6 To 144 Step 6 'F bis EN
lngLast = .Cells(.Rows.Count, lngSpalte).End(xlUp).Row
If lngLast >= 16 Then
With .Range(.Cells(16, lngSpalte), .Cells(lngLast, lngSpalte))
.Copy Destination:=wks.Cells(lngZeile, 156)
lngZeile = lngZeile + .Rows.Count
End With
End If
Next
'Leere Zellen löschen in Zielspalte
If lngZeile > 16 Then
lngLast = .Cells(.Rows.Count, 156).End(xlUp).Row
On Error Resume Next
With .Range(.Cells(16, 156), .Cells(lngLast, 156))
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
End With
End If
End With
'Makrobremsem zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
Set wks = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Forumthread: Spalte kopieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread