|
Hallo zusammen
Vorweg ich bin kein Profi und habe mir das meiste VBA Wissen über Foren selbst erarbeitet. Daher verzeiht mein mögliches Unwissen ^^.
Zum Thema:
Ich habe mir vor einigen Tagen vorgenommen meinem Vater mit einem Makro das verarbeiten von einigen seiner Excel Dateien zu erleichtern. Bis her ging auch alles ganz gut voran nur henge ich jetzt schon den ganzen Tag an einer Stelle. Bis her beginnt das Makro damit, dass es ab einer Bestimmten Zelle beginnt die Zeilen zu zählen, welche mit Inhalt gefüllt sind. Nun soll es wieder zu der bestimmten Zelle zurück und in dieser Zeile alles in einer bestimmten Range kopieren und in einer anderen Exceldatei nun nicht in einer Zeile sondern einer Spalte einfügen. Danach soll es in der ersten Exceldatei quasi eine Zeile runter rutschen wieder alles in einer Range kopieren usw.. Die Zeilen habe ich vorher auszählen lassen weil ich mir gedacht habe, dass man das alles in einen Loop packt der so oft abläuft wie die Anzal der befüllt Zeilen ist. Das ganze funktioniert aber nicht so wie ich das möchte ^^.
Ich stelle hier mal den Code in Netzt und würde mich sowohl über Verbesserungen des Codes als auch andere Voschläge freuen. Falls etwas unverständlich war ich versuche es gerne nochmal individuell zu erklären :
Danke schonmal im Voraus an alle Helfer und Helferinnen.
Code:
Option Explicit
Dim pfad_i As String
Dim Zeilenzahl As Integer
Dim intZeile As Integer
Dim a As Integer
Public Sub zahl()
Range("B7").Select
Zeilenzahl = Selection.CurrentRegion.Rows.Count
Call kopieren()
End Sub
Public Sub kopieren()
Application.ScreenUpdating = False
a = 2
pfad_i = "C:\Beispiel.xls"
Workbooks.Open Filename:=pfad_i
Cells(7, 2).Select
For intZeile = 7 To Zeilenzahl
If Cells(intZeile, 2) <> "" Then
Range(Cells(intZeile, 2), Cells(intZeile, 341)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Vorlage.xltm").Activate
Sheets("Tabelle" & a).Select
Range("K2:K341").PasteSpecial , Transpose:=True
Application.CutCopyMode = False
Workbooks("Beispiel.xls").Close savechanges:=False
Workbooks.Open Filename:=pfad_i
a = a + 1
End If
Next
Application.ScreenUpdating = True
End Sub
|