Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1312to1316
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

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
Anzeige
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

Anzeige
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

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige