Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1568to1572
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

Tabelle in neu Tabelle schreiben

Tabelle in neu Tabelle schreiben
15.07.2017 14:52:04
richar
Hallo Franz, Hallo zusammen,
Bitte kann jemand mir helfen? Ich habe diese code von Franz angepasst aber ich habe ein _ Problem

Sub RFIDAuswertung()
Dim varFile As Variant
Dim wkbZ As Workbook
Dim wkbQ As Workbook
Dim wkbX As Workbook
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim ZeileQ As Long, SpalteQ As Long
Dim ZeileZ As Long, SpalteZ As Long
Dim Spalte As Long
Dim strSuch1 As String, strSuch2 As String
Dim bolTest As Boolean
bolTest = False
strSuch1 = ""
For Each wksZ In ActiveWorkbook.Worksheets
Select Case LCase(wksZ.Name)
Case "tab2", "1z_5t", "9z_6t", "tab5"
strSuch1 = strSuch1 & " """ & wksZ.Name & """"
bolTest = True
Case Else
'do nothing
End Select
Next
If bolTest = True Then
If MsgBox("Die vorhandenen Tabellenblätter " & strSuch1 & " müssen erst gelöscht werden! _
_
", _
vbOKCancel + vbQuestion + vbDefaultButton2) = vbCancel Then
Exit Sub
Else
Application.DisplayAlerts = False
For Each wksZ In ActiveWorkbook.Worksheets
Select Case LCase(wksZ.Name)
Case "tab2", "1z_5t", "9z_6t", "tab5"
wksZ.Delete
Case Else
'do nothing
End Select
Next
Application.DisplayAlerts = True
End If
End If
varFile = Application.GetOpenFilename(Filefilter:="Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx; _
_
*.xlsm", _
Title:="Bitte Datenquelle auswählen")
If varFile = False Then Exit Sub
Set wkbZ = ActiveWorkbook
Set wkbQ = Application.Workbooks.Open(varFile, ReadOnly:=True)
Set wksZ = wkbZ.Worksheets.Add(after:=wkbZ.Sheets(1))
wksZ.Name = "Tab2"
Set wksQ = wkbQ.Worksheets(1)
With wksQ
With .UsedRange
ZeileQ = .Row + .Rows.Count - 1
SpalteQ = .Column + .Columns.Count - 1
End With
.Range(.Cells(1, 1), .Cells(ZeileQ, SpalteQ)).Copy
wksZ.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
.Range(.Cells(1, 1), .Cells(ZeileQ, SpalteQ)).Copy wksZ.Cells(1, 1)
Application.CutCopyMode = False
End With
wkbQ.Close savechanges:=True
Set wksQ = wksZ
wksQ.Copy after:=wkbZ.Sheets(2)
Set wksZ = ActiveSheet
wksZ.Name = "Tab5"
ActiveSheet.Columns("B").Delete
ActiveSheet.Columns("D").Delete
ActiveSheet.Columns("F").Delete
ActiveSheet.Columns("K:M").Delete
' wksZ.Cells(1, SpalteQ + 1).Value = "klt"
' Zeile löschen
Dim z As Long, lZ As Long
lZ = Sheets("Tab5").Cells(65536, 1).End(xlUp).Row
For z = lZ To 1 Step -1
With Sheets("Tab5")
If .Cells(z, 3).Value = "" Then .Rows(z).Delete
End With
'*********** da mein Problem******************
'ich möchte hier auf meine Tab5 diese suchbegrffe, es mach nicht was ich will, 'weil die  _
obersteblatt fixiert ist
'wie mache ich sodass ich jetzt auf die Tab5 arbeite? Oberste Zeile ist weniger 'geworden
With wksQ
ZeileZ = 1
Set wksZ = wkbZ.Worksheets("Tab5")
strSuch1 = "9z": strSuch2 = "6t"
For ZeileQ = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
If .Cells(ZeileQ, 2).Text = strSuch1 Or .Cells(ZeileQ, 2).Text = strSuch2 Then
ZeileZ = ZeileZ + 1
.Rows(ZeileQ).Copy Destination:=wksZ.Rows(ZeileZ)
End If
Next
End With
wksQ.Copy after:=wkbZ.Sheets(3)
Set wksZ = ActiveSheet
wksZ.Name = "Tab3"
ActiveSheet.Columns("B").Delete
ActiveSheet.Columns("D").Delete
ActiveSheet.Columns("F").Delete
ActiveSheet.Columns("K:M").Delete
'wksZ.Cells(1, SpalteQ + 1).Value = "klt"
' Zeile löschen
lZ = Sheets("Tab3").Cells(65536, 1).End(xlUp).Row
For z = lZ To 1 Step -1
With Sheets("Tab3")
If .Cells(z, 3).Value = "" Then .Rows(z).Delete
End With
Next
'***************da mein Problem*************************
'ich möchte hier auf meine Tab3 diese suchbegrffe, es mach nicht was ich will, 'weil die  _
obersteblatt fixiert ist
'wie mache ich sodass ich jetzt auf die Tab3 arbeite? Oberste Zeile ist weniger 'geworden
With wksQ
ZeileZ = 1
Set wksZ = wkbZ.Worksheets("Tab3")
strSuch1 = "1z": strSuch2 = "5t"
For ZeileQ = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
If .Cells(ZeileQ, 2).Text = strSuch1 Or .Cells(ZeileQ, 2).Text = strSuch2 Then
ZeileZ = ZeileZ + 1
.Rows(ZeileQ).Copy Destination:=wksZ.Rows(ZeileZ)
End If
Next
End With
End Sub

Die Ursprung Tab2 hatte viele unnötige Spalte und Zeile die ich lösche und dann kopiere ich im Tab5 und Tab3 mit Suchbegriffe
Wie ich im Kommentar im code geschrieben habe, möchte ich nicht oberste zeile fixieren, da ich ein paar spalte gelöscht habe und in Tab5 bzw Tab3 geschrieben.
Ich möchte jetzt dass Tab5 und Tab3 neu Tabelle ist.
Wo mein Problem ist habe ich im Code als Kommentar nochmal geschrieben.
Bitte kann jemand mir helfen?
Ich bedanke mich
Grüß
Richar

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabelle in neu Tabelle schreiben
21.07.2017 18:44:17
fcs
Hallo Richar,
ich hab mal versucht die Fensterfixierung an den Stellen abzuschalten, wo du die Probleme siehst.
Ansonsten wäre es extrem hilfreich, wenn du so langen Code-Text in einer Excel-Datei hochlädst. Dann gibt es keine unschöne Zeilenumbrüche.
Datei mit angepasstemMakro-Code
https://www.herber.de/bbs/user/115002.txt
Die Probleme beim Suchen kann ich ich ohne Beispieldaten nicht nachvollziehen.
Dazu bräuchte ich die Dateien
A) Datei mit dem Makro
B) Datendatei (Auszug), die eingelesen werden soll, ggf. sensibl/Personenbezogene Daten anonymisiert.
LG
Franz
Anzeige

301 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige