PDA

Vollständige Version anzeigen : Copy von Tabellenblätter


PSzepan
22.05.2013, 15:37
Hallo,

ich habe echt ein Problem, und komme nicht weiter :(

Ich habe sehr viel Arbeitsmappen mit Tabellenblätter sie sehen alle gleich aus...
Ich möchte jetzt eine Mappe per Box öffnen und dann einen Bereich copyren in das neue Tabelenblatt aber nur wenn in Spalte B3, B4, B5..... unentlich zb das Wort "Adobe" ist so weit so gut

Ich habe jetzt einen Code gebastelt was so weit alles macht nur nicht das mit dem Adobe er Copyrt alle von B3 - K50000 und ich weis nicht wie ich dem Code das beibringen soll habe schon alles versucht darum hier mal der grund code der alles Copyrt





Option Explicit
Dim Stamm As String
Dim varFile As Variant
Dim varName As Variant
Dim Blatt As String
Dim i As Integer
Dim abfrage As Byte

Sub GLM_Product_List_Adobe()
'
' Import_GLM Product List Adobe Makro
'

abfrage = MsgBox("Warning! This function will override the complete GLM Product List Adobe! OK?", 1, "Vorsicht!")
If abfrage = 2 Then
Exit Sub
End If

On Error GoTo Err
Stamm = ActiveWorkbook.Name
varFile = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Auswahl", , False)
If TypeName(varFile) Like "Boolean" Then
MsgBox "Keine Datei gewählt!", vbInformation
Exit Sub
Else
varName = Right$(varFile, Len(varFile) - InStrRev(varFile, "\"))
Workbooks.Open varFile


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

' Welche Zellen sollen übertragen werden?

Workbooks(Stamm).Activate

Workbooks(varName).Sheets("Produktliste vollständig").Range("B3:K5000").Copy 'Position im altem Sheet
Workbooks(Stamm).Sheets("GLM Product List Adobe").Range("B3:K5000").PasteSpecial xlPasteValues 'Position im neuem Sheet


Workbooks(varName).Close

Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.EnableEvents = True

MsgBox ("Alte Tabelle wurde erfolgreich importiert!")

Application.ScreenUpdating = True
End If
Exit Sub
Err:
Call MsgBox("Es ist ein Fehler aufgetreten!" _
& vbCrLf & " Fehler" _
, vbExclamation, "Fehler")
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

'Leere Zeilen löschen'
Dim line As Variant
For line = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
With Range(Cells(line, 1), Cells(line, 5000))
If Application.WorksheetFunction.CountBlank(.Cells) = .Cells.Count Then
Rows(line).Delete
End If
End With
Next
'end

'
End Sub





ich hoffe Ihr könnt mir Helfen da ich das mit Microsoft mir Oracle und viele anderen Themen machen muss und das über ca 400 Tabelenblätter

Beverly
22.05.2013, 16:36
Hi,

da musst du in einer Schleife über alle Zeilen laufen, prüfen ob in B "Adobe" steht und nur dann kopieren. Ersetze in deinem Code die beiden Zeilen

Workbooks(varName).Sheets("Produktliste vollständig").Range("B3:K5000").Copy 'Position im altem Sheet
Workbooks(Stamm).Sheets("GLM Product List Adobe").Range("B3:K5000").PasteSpecial xlPasteValues 'Position im neuem Sheet

durch diese

Dim lngLetzte As Long
Dim lngZeile As Long
With Workbooks(Stamm).Sheets("GLM Product List Adobe")
If Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & lngZeile) = "Adobe" Then
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count) + 1
Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & lngZeile & ":K" & lngZeile).Copy 'Position im altem Sheet
.Range("B" & lngLetzte & ":K" & lngLetzte).PasteSpecial xlPasteValues 'Position im neuem Sheet
End If
End With


Ich konnte den Code nicht testen, da mir deine Mappen nicht vorliegen.

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/" onclick="window.open(this.href);return false"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

Hasso
22.05.2013, 16:41
Hallo PSzepan,Ich habe jetzt einen Code gebastelt was so weit alles macht nur nicht das mit dem Adobe er Copyrt alle von B3 - K50000 und ich weis nicht wie ich dem Code das beibringen soll habe schon alles versucht darum hier mal der grund code der alles CopyrtDas steht ja auch nirgends in deinem Code!

Ich habe den Teil mit dem Kopieren der Zeilen, in denen "Adobe" vorkommt, jetzt so gelöst:Option Explicit

Private Sub CommandButton1_Click()
Dim rowZeile As Range
Dim lngLetzteZeile As Long
Dim lngLetzteSpalte As Long
Dim lngZielZeile As Long
Dim i As Long
Dim rngZelle As Range

lngLetzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lngZielZeile = 1
Worksheets("Tabelle2").UsedRange.ClearContents

For Each rngZelle In Worksheets("Tabelle1").Range("A1:A" & lngLetzteZeile)
lngLetzteSpalte = Worksheets("Tabelle1").Cells(rngZelle.Row, Columns.Count).End(xlToLeft).Column
If WorksheetFunction.CountIf(Range(rngZelle.Row & ":" & rngZelle.Row), "Adobe") > 0 Then
Range(rngZelle.Row & ":" & rngZelle.Row).Copy _
Destination:=Worksheets("Tabelle2").Cells(lngZielZeile, 1)
lngZielZeile = lngZielZeile + 1
End If
Next rngZelle

End Sub

Beispielmappe anbei.

PSzepan
22.05.2013, 16:53
Hallo Beverly,

das schaur schon mal super aus aber er bricht mit einem Fehler leider ab.

Ich kann Dir gern mal die 2 Listen geben das du sehen kannst von was ich spreche....

aber ich glaube du bist auf dem richtigen weg :) 1000Mil Dank schon mal

Beverly
22.05.2013, 16:55
Hi,

an welcher Stelle tritt der Fehler auf und was genau sagt der Debugger?

Die Mappen kannst du hier im Forum hochladen (mit ein paar Beispielinhalten - muss nicht der gesamte Inhalt sein)

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/" onclick="window.open(this.href);return false"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

PSzepan
22.05.2013, 17:07
Hallo Beverly,

leider kann ich die 2 datein nicht hochladen die eine ist ca. 11,7MB

aber nur einen auszug macht kein sinn da alles miteinander verbunden ist :(

und ein Fehler spuckt nicht Excel wirklich aus sonder ein PopUp das das einlesen Fehl geschlagen ist

Beverly
22.05.2013, 17:15
Hi,

dann kommentiere mal die Zeile On Error Goto Err aus und lasse den Code noch einmal laufen. Dann siehst du, in welcher Zeile er hängenbleibt.

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/" onclick="window.open(this.href);return false"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

PSzepan
22.05.2013, 17:22
Laufzeitfehler 1004

If Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & lngZeile) = "Adobe" Then

PSzepan
22.05.2013, 17:24
Option Explicit
Dim Stamm As String
Dim varFile As Variant
Dim varName As Variant
Dim Blatt As String
Dim i As Integer
Dim abfrage As Byte
Dim lngLetzte As Long
Dim lngZeile As Long

Sub GLM_Product_List_Adobe()
'
' Import_GLM Product List Adobe Makro
'

abfrage = MsgBox("Warning! This function will override the complete GLM Product List Adobe! OK?", 1, "Vorsicht!")
If abfrage = 2 Then
Exit Sub
End If

'On Error GoTo Err
Stamm = ActiveWorkbook.Name
varFile = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Auswahl", , False)
If TypeName(varFile) Like "Boolean" Then
MsgBox "Keine Datei gewählt!", vbInformation
Exit Sub
Else
varName = Right$(varFile, Len(varFile) - InStrRev(varFile, "\"))
Workbooks.Open varFile


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

' Welche Zellen sollen übertragen werden?

Workbooks(Stamm).Activate

With Workbooks(Stamm).Sheets("GLM Product List Adobe")
If Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & lngZeile) = "Adobe" Then
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count) + 1
Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & lngZeile & ":K" & lngZeile).Copy 'Position im altem Sheet
.Range("B" & lngLetzte & ":K" & lngLetzte).PasteSpecial xlPasteValues 'Position im neuem Sheet
End If
End With


Workbooks(varName).Close

Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.EnableEvents = True

MsgBox ("Alte Tabelle wurde erfolgreich importiert!")

Application.ScreenUpdating = True
End If
Exit Sub
Err:
Call MsgBox("Es ist ein Fehler aufgetreten!" _
& vbCrLf & " Fehler" _
, vbExclamation, "Fehler")
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

'Leere Zeilen löschen'
Dim line As Variant
For line = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
With Range(Cells(line, 1), Cells(line, 5000))
If Application.WorksheetFunction.CountBlank(.Cells) = .Cells.Count Then
Rows(line).Delete
End If
End With
Next
'end

'
End Sub

Beverly
22.05.2013, 17:36
da habe ich dir den wichtigsten Teil - die Schliefe - unterschlagen. Ändere den Teil so:

With Workbooks(Stamm).Sheets("GLM Product List Adobe")
For lngZeile = 1 To 3000
If Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & lngZeile) = "Adobe" Then
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count) + 1
Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & lngZeile & ":K" & lngZeile).Copy 'Position im altem Sheet
.Range("B" & lngLetzte & ":K" & lngLetzte).PasteSpecial xlPasteValues 'Position im neuem Sheet
End If
Next lngZeile
End With

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/" onclick="window.open(this.href);return false"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

PSzepan
22.05.2013, 17:54
da stimmt was nicht er bricht zwar nicht mit einem fehler ab aber er arbeitet seit dem du mit den Code gegeben hast ohne unterbrechnung das kann doch nicht sein so lange für 2800 Zeilen Copy ging ohne die abfrage in 6Sek. was mache ich dann bei Microsoft mit 11000 Zeilen :(

Beverly
22.05.2013, 18:15
bei deinem Ausgangscode kopierst du den gesamten Bereich als ein Ganzes - hier wird jede Zeile duchlaufen und geprüft, was natürlich länger dauert.
Ich frage mich allerings, wozu du den letzen Teil in deinem Code für das Löschen der Leerzeilen benötigst - da jetzt keine Leerzeilen mehr vorkommen, weil nur die Zeilen mit "Adobe" kopiert werden, brauchst du den m.E. nicht mehr, er verlängert natürlich den ganzen Codeablauf ebenfalls.

Es gibt noch die Möglichkeit, direkt nach "Adobe" zu suchen und damit nicht jede Zeile durchlaufen zu müssen. Ändere meinen Teil so:

Dim rngZelle As Range
Dim strStart As String
With ThisWorkbook.Sheets("GLM Product List Adobe")
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count) + 1
End With
With Workbooks(varName).Sheets("Produktliste vollständig")
Set rngZelle = .Columns(2).Find("Adobe", lookat:=xlWhole, LookIn:=xlValues)
If Not rngZelle Is Nothing Then
strStart = rngZelle.Address
Do
Workbooks(varName).Sheets("Produktliste vollständig").Range("B" & rngZelle.Row & ":K" & rngZelle.Row).Copy 'Position im altem Sheet
ThisWorkbook.Sheets("GLM Product List Adobe").Range("B" & lngLetzte & ":K" & lngLetzte).PasteSpecial xlPasteValues 'Position im neuem Sheet
lngLetzte = lngLetzte + 1
Set rngZelle = .Columns(2).FindNext(rngZelle)
Loop While Not rngZelle Is Nothing And rngZelle.Address <> strStart
End If
End With
Set rngZelle = Nothing

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/" onclick="window.open(this.href);return false"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

PSzepan
23.05.2013, 09:19
Hallo Beverly,

danke für deine Hilfe... also mit dem neuen code habe ich nach 30Min abgebrochen und er hatte da gerade mal 351 Zeilen Copyrt :(

Fileicht noch eine hilfe oder Tip also aus der Liste die ich Copyre sind nur Adobe Produkte das heist in Spalte B3-B????
ich muss also nur copyren was gefült ist und das in die Ziehl liste immer anfangend bei B3 einfügen usw.

Ich sitze schon seit 2 Wochen an dem Problem da ich mit VBA mich nicht gut auskenne und hir an die genzen stosse nach unzähligen Büchern war das meine letzte hofnung :)

Mit dem Code :

Workbooks(varName).Sheets("Produktliste vollständig").Range("B3:K5000").Copy 'Position im altem Sheet
Workbooks(Stamm).Sheets("GLM Product List Adobe").Range("B3:K5000").PasteSpecial xlPasteValues 'Position im neuem Sheet
macht er genau das was ich ja will und mega schnell doch leider macht er da auch wirklich von B3 bis K5000 und das wiederum brauch in in der ziehl liste auf keinen fall es dürfen nur zB in meinem fall heute 2867 zeilen rüber das kann morgen schon wieder mehr oder weniger sein :(

das ist das Problem :( ich weis es nie ich könnte fedes mal erst nachschauen und dann die zahl ändern im VBA aber es solte doch möglich sein per VBA die letzte Zahl in B wo zB ADOBE steht heraus zu finden und dann auf ein mal wie mein ursprungs Cod war es zu übergeben und dann ZB


Workbooks(varName).Sheets("Produktliste vollständig").Range("B3:K2867").Copy 'Position im altem Sheet
Workbooks(Stamm).Sheets("GLM Product List Adobe").Range("B3:K2867").PasteSpecial xlPasteValues 'Position im neuem Sheet

das wäre so cool :) dann wäre das so wie ich es brauche und das kann ich dan für jeden hersteller machen :) in einem eigenen Modul

ich weis echt nicht mehr weiter :( habe schon so viel versucht und es solte schon lange fertig sein :(

Beverly
23.05.2013, 09:36
Hi,

also ich habe das in meiner Mappe getestet - da war er innerhalb von wenigen Sekunden mit dem Kopieren fertig. Folglich muss an deiner Mappe irgendetwas anders sein als an meiner - da ich deine jedoch nicht kenne, kann ich zu diesem Problem leider nicht sagen.

Aus deinem jetzigen Beitrag würde ich - entgegen deinem Eröffnungsbeitrag - entnehmen, dass es nicht darum geht, dass nur Zeilen mit dem Wort "Adobe" in Spalte B kopiert werden sollen, sondern dass in allen Zeilen in Spalte B "Adobe" steht und es sich nur jeweils um eine unterschiedliche Anzahl an Zeilen handelt.

With Workbooks(varName).Sheets("Produktliste vollständig")
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
.Range(.Cells(3, 2), .Cells(lngLetzte, 11)).Copy
ThisWorkbook.Sheets("GLM Product List Adobe").Range("B3").PasteSpecial xlPasteValues 'Position im neuem Sheet
End With

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/" onclick="window.open(this.href);return false"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

PSzepan
23.05.2013, 10:00
Hallo Bevely,

es geht jetzt in 3 Sek :) aber denoch geht es nicht und ich bin so weit wie am anfang :(

den aus einem grund sind die daten so in der Ziel Liste das er dort meint das es bis B5000 gefült ist den ich muss aus 6 Listen dann eine machen
aber jetzt habe ich Adobe 5000 Produkte und nicht nur 2867 wie gesagt das ist eine 11,7MB große Excel liste die ins sich jede mänge listen hat die immer wieder geteilt werden und zusamengefügt werden ... usw ... und es darf in der Ziehl liste nur für das weitere verarbeiten ...

Kann ich dir nicht mal das teil schicken um dir ein bild zu machen was ich meine

Beverly
23.05.2013, 10:17
Hi,

sorry, ich verstehe leider deine Aussage nicht

es geht jetzt in 3 Sek aber denoch geht es nicht und ich bin so weit wie am anfang



Da musst du schon etwas genauer werden WAS nicht geht.

Wenn du eine oder mehrere Datein bereitstellen willst, dann erstelle eine Kopie deiner Originaldatei und verringere die Anzahl an Daten, sodass sie im Forum hochgeladen werden kann.

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/" onclick="window.open(this.href);return false"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

PSzepan
23.05.2013, 10:36
Hi,
also das mit dem minimiren geht nicht den wenn ich was aus den tabellen raus nähme geht das ganze teil nicht mehr :(

Also ich weis nicht wie ich es erklären soll auf allen listen liegen Filter und div andere dinge und wenn jetzt eine liste eingeladen wird was jetzt mit dem code von dir geht zerstört aber irgent wie was anderes ich weis nicht was ;(

das heist wenn ich dan alle listen Adobe Microsoft und so weiter zu einer grosen machen war (soll) es so sein das es dann zb B2 bis zb b2867 Adobe dan microsoft dan Oracle dan .... stehen und dann dann man die mit einem Dropbox suchen doch jetzt steht B2 bis 5000 abobe bzw B2 - B2867 Adbobe der rest leer dan kommt Microsoft und so weiter er erkännt nun nicht mehr in der Ziehl liste das es bei 2867 schluss ist aber ich kann dir nicht sagen warum wenn ich manuel es in der Ziehlliste eintrage dann geht es ohne probleme also eine produkt nach dem anderen ... aber wenn ich es einlesen lasse per VBA dank deiner hilfe geht es nicht mehr :(

Ich glaube weil die Ziehl Tabelle als (Als Tabelle Formatiert) ist und dort wenn man am ende der tabele ist eine neue zeile einfügt
doch wen ich es kopiere siht man auch schon das der Obere bereich der schon da war anderst Firmatiert ist als das was dann nachträglich eingelesen wurde

ich kann es dir besser zeigen wenn du die liste hättest ich weis nur nicht wie ich es dir geben kann

JohnDoe
23.05.2013, 10:53
Hi,

Datei zipen, mit Passwortschutz, wenn es dir lieber ist, dann nutzt einen der vorhanden Sharingdienste (rapidhsare) und lädst die Datei da hoch, evtl. auch mit Passwort versehen.
Dann kannst du den entsprechenden Link einstellen und den interessierten das Passwort mitteilen.

VG
JD

PSzepan
23.05.2013, 11:09
Gute Idee aber nicht möglich hier im netz ich komme auf nichts drauf bin froh hier ins Forum zu kommen