AW: Namensfelder-Zeilenexport in neue Tabelle
28.10.2017 12:22:12
fcs
Hallo Markus,
bei Zellen mit Namen musst du eigentlich den Namen (ohne Zählnummer) angeben und dann kann man die Namen in einer Schleife abarbeiten.
Allerdings verstehe ich den Sinn -besser Unsinn- nicht, warum du einen großen Zellbereich mit Namen zupflasterst. Excel hat Grenzen bei verschiedensten Werten - meines Wissens gibt es auch eine Grenze bei der Anzahl Namen je Blatt/Datei. Dadurch auch deine früheren Probleme beim Zuweisen der Namen.
Das kann man mit Sicherheit eleganter lösen, wenn man sehr viele genauer wüsste, was du eigentlich machen und erreichen willst.
Zum selektiven Kopieren von Spalten eines selektierten Zellbereichs hab ich die auch etwas gebastelt.
Dieses Makro musst du starten nachdem du die zu kopierenden Zellen selektiert hast.
Gruß
Franz
Sub Zellen_mit_Name_pruefen()
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim sName As String
Dim objRange As Object
On Error GoTo Fehler
Eingabe:
sName = InputBox("Zu durchender Namensbereich (ohne Zählnummer eingeben!)", _
"Zeilen mit leerer Zelle kopieren", "Albert")
If sName = "" Then Exit Sub 'Abbrechen gewählt
With Tabelle1
'Prüfen ob Name im Blatt definiert ist
If fncChecknameSheet(ThisWorkbook.Worksheets(.Name), sName & "1") = True Then
Set objName = ThisWorkbook.Worksheets(.Name)
'Prüfen ob Name im aktiven Workbook definiert ist
ElseIf fncChecknameApplication(sName & "1") = True Then
Set objName = Application
Else
MsgBox "Name """ & sName & "1 "" existiert nicht. Bitte vorhandenen Namen " _
& "wählen!", _
vbOKOnly + vbInformation, "Zellen mit Namen prüfen"
GoTo Eingabe
End If
ZeileMax = .UsedRange.Rows.Count 'ggf. Zähler fest vorgeben entsprechend Anzahl Namen- _
Nummern
n = 1
For Zeile = 1 To ZeileMax
If objName.Range(sName & Zeile).Value = "" Then
objName.Range(sName & Zeile).EntireRow.Copy Destination:=Tabelle3.Rows(n)
n = n + 1
End If
Resume_NextZeile:
Next Zeile
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 1004
'Name in Namensliste nicht gefunden
Resume Resume_NextZeile
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Function fncChecknameSheet(wks As Worksheet, sName As String) As Boolean
Dim rngTest As Range
On Error GoTo Fehler
fncCheckname = False
Set rngTest = wks.Range(sName)
fncChecknameSheet = True
Exit Function
Fehler:
End Function
Function fncChecknameApplication(sName As String) As Boolean
Dim rngTest As Range
On Error GoTo Fehler
fncCheckname = False
Set rngTest = Application.Range(sName)
fncChecknameApplication = True
Exit Function
Fehler:
End Function
'Makro zum selektiven Kopieren von Spalten
Sub Kopieren_selektiv_einfuegen()
Dim rngCopy As Range
Dim rngTarget As Range
Dim strReihenfolge
Dim arrRF, intRF
On Error GoTo Fehler
Set rngCopy = Selection
EingabeReihenfolge:
strReihenfolge = InputBox("Bitte Nummern der zu kopierenden Spalten in der " _
& "gewünschten Reihenfolge eingeben, getrennt durch Semikolon" & vbLf _
& "Anzahl Spalten im Bereich: " & rngCopy.Columns.Count, _
"Spalten selektiv kopieren", "2;4")
If strReihenfolge = "" Then Exit Sub
arrRF = Split(strReihenfolge, ";")
'Prüfen ob Auswahl der Spalten korrekt
For intRF = LBound(arrRF) To UBound(arrRF)
If Val(Trim(arrRF(intRF))) rngCopy.Columns.Count Then
MsgBox "Eingegebene Werte sind Text, Anzahl Spalten im selekierten " _
& "Bereich!", _
vbOKOnly + vbInformation, "Spalten selektiv kopieren"
GoTo EingabeReihenfolge
End If
Next
Auswahl_Zielzelle:
Set rngTarget = Application.InputBox( _
"Bitte linke obere Zelle auf dem Ziel-Tabellenblatt wählen, ab der eingefügt "_
& "werden soll.", _
"Spalten selektiv kopieren", Type:=8)
If rngCopy.Rows.Count = rngCopy.Parent.Rows.Count And rngTarget.Row > 1 Then
MsgBox "Wenn ganze Spalten kopiert werden sollen, dann muss die Zielzelle " _
& "in der 1. Zeile gewählt werden!", _
vbOKOnly + vbInformation, "Spalten selektiv kopieren"
GoTo Auswahl_Zielzelle
ElseIf rngCopy.Rows.Count + rngTarget.Row - 1 > rngTarget.Parent.Rows.Count Then
MsgBox "Selektierter Zellbereich hat zuviele Zeilen, um diesen ab der Zielzelle " _
& "einzufügen!" & vbLf _
& "Zielzelle muss oberhalb von Zeile " & rngTarget.Parent.Rows.Count _
- rngCopy.Rows.Count + 2 & " gewählt werden!", _
vbOKOnly + vbInformation, "Spalten selektiv kopieren"
GoTo Auswahl_Zielzelle
End If
For intRF = LBound(arrRF) To UBound(arrRF)
rngCopy.Columns(Val(arrRF(intRF))).Copy Destination:=rngTarget.Offset(0, intRF)
Next
rngTarget.Parent.Activate
Fehler:
With Err
Select Case .Number
Case 0 ' alles OK
Case 424
'Zellauswahl in Inputbox wurde abgebrochen
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub