PDA

Vollständige Version anzeigen : Array aus Tabellenmatrix füllen


Beti#
17.07.2012, 14:44
Hallo zusammen,

ich habe folgendes Problem meine Datenquelle sieht so aus
Spalte A ..... B.....C......D.......E.....
Zeile 54.....60...""......40.....15
.......... 12.....11---5.....18.......13
...........14......10...""......5.......7

Was ich möchte und einfach nicht hinbekomme ist folgendes :(
Das Makro soll erst mal Spalte C überprüfen ob da leerzeichen drin stehen.
Falls nicht soll er die komplette Zeile von Spalte A bis Spalte E in ein Array schreiben (Zeile für Zeile müsste es durchgehen) und dann das Tabellenblatt wechseln und das Array dann in die nächste leere Zeile schreiben.

Wäre super wenn mir jemand helfen könnte.

Vielen Dank

Gruss

Beti

EarlFred
17.07.2012, 14:54
Hallo Beti,

ein Ansatz über AutoFilter kommt nicht in Frage?

Grüße
EarlFred

Beti#
17.07.2012, 15:06
Hi EarlFred,

ne leider nicht. Da ich die Daten in ein neues Tabellenblatt schreiben muss.
Ich habe es soweit hinbekommen, dass geprüft wird ob in Spalte C etwas drin steht wenn ja koppiert er es rüber. Das Problem ist, dass er sofort sobald er etwas in Spalte C findest die ganze Spalte kopiert und auf das neue Tabellenblatt springt und es dort einfügt. Dann springt er wieder auf das Ursprungsblatt und sucht weiter. Aber das dauert zu lange bei etwa 80 zu prüfenden Zellen in Spalte C und das hin und herkopiere. Deswegen das Array. Ich hoffe das es damit schneller geht.

Gruß

beti

EarlFred
17.07.2012, 15:10
Hallo Beti,

OK, meine Gedankenskizze mal etwas "ordentlicher" aufgemalt:
Autofilter auf Spalte C setzen, auf "nichtleere" Zellen filtern.
Den gesamten Bereich (es werden nur die sichtbaren Zellen genommen) kopieren und in der anderen Tabelle einfügen. Diese Methode ist ausreichend schnell.

Blätter, Bereiche etc. müssen zudem nicht ausgewählt werden, um solche Aktionen auszuführen. Unter anderem wird der Code dadurch unnötig ausgebremst.
Zeig mal Deinen Code - dann wird's vielleicht einfacher, den anzupassen.

Grüße
EarlFred

Beti#
17.07.2012, 15:14
okay hier mein bisheriger Code.

Rows("4:500").Select
Selection.EntireRow.Hidden = False

y = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Dim db As Range
Dim dc As Range

For i = 4 To y

If Range(Cells(i, 18), Cells(i, 18)).Value <> "" Then

Range(Cells(i, 1), Cells(i, 28)).Select
Selection.Copy
Sheets("DB").Select
yz = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Cells(yz + 1, 2).Select
ActiveSheet.Paste
Sheets("Erfassung").Select


End If
Next








Sheets("Erfassung").Select
Range("A1").Select
Selection.Copy
Sheets("DB").Select
c = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
A = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Range(Cells(c + 1, 1), Cells(A, 1)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Erfassung").Select

Application.EnableEvents = False



Range(Cells(4, 1), Cells(y, 30)) = ""



Application.EnableEvents = True



UserForm2.Hide

Application.ScreenUpdating = True

End Sub

Gruß Beti

EarlFred
17.07.2012, 15:46
Hallo Beti,

mit Verzicht auf die "Selecterei" könnte der Code etwas entschlackt werden und auch schneller sein:
Option Explicit

Sub Beti()
Dim lngLast As Long 'vormals Variable y
Dim i As Long

With Worksheets("Erfassung")
.Rows("4:500").EntireRow.Hidden = False
lngLast = .Cells(Rows.Count, 1).End(xlUp).Row

For i = 4 To lngLast

If .Cells(i, 18).Value <> "" Then
.Range(.Cells(i, 1), .Cells(i, 28)).Copy
Worksheets("DB").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

End If

Next i

Application.CutCopyMode = False
'.Range(.Cells(4, 1), .Cells(lngLast, 30)).ClearContents

End With

End Sub

Probiere aber auf alle Fälle auch folgende Variante:
Option Explicit

Sub Beti_mit_AutoFilter()

Dim lngLast As Long

With Worksheets("Erfassung")
.Rows("4:500").EntireRow.Hidden = False
lngLast = .Cells(Rows.Count, 1).End(xlUp).Row

.Range(.Cells(3, 1), .Cells(lngLast, 28)).AutoFilter Field:=18, Criteria1:="<>"
.Range(.Cells(4, 1), .Cells(lngLast, 28)).Copy

Worksheets("DB").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False

.Range(.Cells(4, 1), .Cells(lngLast, 30)).ClearContents

Application.CutCopyMode = False

End With

End Sub
Ich hoffe, diese ist von der Performance her zufriedenstellend.


Grüße
EarlFred

Beti#
17.07.2012, 15:53
Hi EarlFred,

okay werde ich heute abend ausprobieren. Melde mich dann mit dem Ergebnis :).

Vielen Dank schon Mal für die schnelle "Erste Hilfe" ;).

Gruß

Beti

Beti#
23.07.2012, 15:24
Hallo EarlFred,

ich habe das mit dem Autofilter ein wenig angepasst und jetzt läufts ;).
Von der Performance her ist es auch mega schnell.

Vielen Dank ;)

Viele Dir schickende dankende Grüße Beti

EarlFred
23.07.2012, 15:30
Hallo Beti,

gern geschehen und Danke für die nette Rückmeldung.

Grüße
EarlFred