HERBERS Excel-Forum - das Archiv
Thema: Spalten definieren | Herbers Excel-Forum
-
Spalten definierenClaudia
-
AW: Spalten definierenClaudia
-
teste mal.Tino
-
AW: teste mal. ---> noch FehlerClaudia
-
noch ein versuch...Tino
-
@ SeppClaudia
-
@ Franz:Claudia
-
@ Franz: ---> offen vergessenClaudia
-
@Franz: vielen Dank !Claudia
Spalten definieren
Claudia
Hallo zusammen,
ich bin mal wieder auf der Suche nach einer großen Erleichterung.
Ich muss regelmässig Spalten mit Namen definieren. Da das doch ziemlich viel Arbeit ist, wäre die Frage, ob man sowas nicht mittels einer Makros machen kann.
Folgende Überlegung hatte ich:
Ich trage im Blatt "Blattnamen" ab Zelle A20 die Namen ein und in die Spalte B den Buchstaben der Spalte (z.B. AB) und sie sollen dann per Makro in das nächste Tabellenblatt eingetragen werden. Wenn der Name vergeben wurde, soll das in der Spalte C mit "ok" festgehalten werden. Hat die betreffende Spalte aber schon einen Namen, so soll dieser nicht überschrieben werden, sondern es soll in Spalte C der Status "prüfen" eingetragen werden. Und das dann mittels einer Schleife bis zur letzten gefüllten Zelle in Spalte A.
Das ist doch sicher - so wie ich Euch "Jungs" kenne, ein Klacks für Euch :-)
Kann mir hier jemand denn helfen?
Liebe Grüße
Claudia
AW: Spalten definieren
fcs
Hallo Claudia,
hier mein Vorschlag. Ich bin mal davon ausgegengen, dass die Spaltentitel dann in Zeile1 des anderen Blattes geprüft werden sollen.
Gruß
Franz
Sub Spaltentitel()
Dim wksNamen As Worksheet, wksZiel As Worksheet
Dim Zeile As Long, strName As String, strSpalte As String
Set wksNamen = Worksheets("Blattnamen")
Set wksZiel = Worksheets(wksNamen.Index + 1)
With wksNamen
For Zeile = 20 To .Cells(.Rows.Count, 1).End(xlUp).Row
strName = .Cells(Zeile, 1).Text
strSpalte = .Cells(Zeile, 2)
If wksZiel.Range(strSpalte & "1") = "" Then
wksZiel.Range(strSpalte & "1") = strName
.Cells(Zeile, 3).Value = "Ok"
ElseIf wksZiel.Range(strSpalte & "1") = strName Then
.Cells(Zeile, 3).Value = "Ok"
Else
.Cells(Zeile, 3).Value = "prüfen"
End If
Next
End With
End Sub
AW: Spalten definieren
Tino
Hallo,
kannst ja mal testen.
In Tabelle Blattnamen ab A2 stehen die Namen in B die Spalte als Buchstabe.
Erstellt werden die Namen in der Tabelle rechts neben Blattnamen.
Nicht ausgiebig getestet.
Function CheckName(ByVal rngBereich As Range, ByVal strName$) As Boolean
Dim oName As Name
For Each oName In ThisWorkbook.Names
If oName.Name <> strName Then
If Range(oName.Name).Address(External:=True) = rngBereich.Address(External:=True) Then _
CheckName = True: Exit Function
End If
Next oName
End Function
Sub Test()
Dim meAr()
Dim LLetzte As Long, A As Long
Dim rngBereich As Range
With Sheets("Blattnamen")
LLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
If LLetzte < 2 Then
MsgBox "Keine Daten im Bereich"
Exit Sub
End If
meAr = .Range(.Cells(2, 1), .Cells(LLetzte, 3)).Value2
With Sheets(.Index + 1)
For A = 1 To Ubound(meAr)
If meAr(A, 1) <> "" Then
On Error Resume Next
Set rngBereich = .Columns(meAr(A, 2))
On Error GoTo 0
If Not rngBereich Is Nothing Then
If Not CheckName(rngBereich, meAr(A, 1)) Then
ThisWorkbook.Names.Add Name:=meAr(A, 1), RefersTo:=rngBereich
meAr(A, 3) = ""
Set rngBereich = Nothing
Else
meAr(A, 3) = "überprüfen"
End If
Else
meAr(A, 3) = "überprüfen"
End If
End If
Next A
End With
.Cells(2, 1).Resize(Ubound(meAr), Ubound(meAr, 2)) = meAr
End With
End Sub
AW: Spalten definieren
Claudia
Hallo zusammen,
vielen Dank für Eure Hilfe! Leider klappt es aber noch nichit so ganz:
@ Tino: Bei Dir sagt das Makro überprüfen, obwohl die Spalte keinen Namen hat.
@ fcs: Bei Dir schreibt das Makro in die Zelle 1 der Spalte den Namen.
Vielleicht habe ich mich falsch ausgedrückt: Der Name soll für die gesamte Spalte genommen werden. Ich mache das manuell über Namen defininieren bzw. das Eingabefeld wo der Zellname steht.
Aber so schlimm wäre das gar nicht. Ich würde daher gerne mein Makro erweitern und hoffe, dass Ihr jetzt nicht "ausflippt". Bin halt ein Mädchen. :-)
1) Spaltennamen definieren analog Eintrag in Spalte A
2) Der Name aus Spalte A soll auch in Zelle 1 dieser betreffenden Spalte geschrieben werden
3) die Spalte (z.B. AB) steht nach wie vor in B
4) Ich würde gerne eine Spaltengröße mitgeben (steht nix in C, dann bleibt die Spaltengröße). Das könnte ich ja in Spalte C schreiben. Und in Spalte D käme der Status von Euch.
Die Prüfung passiert nur bei 1. Trägt die gesamte Spalte keinen Namen, kann also durchgeführt werden. Das gilt auch für den Fall, wenn der Spaltenname mit dem zu vergebenden Spaltennamen identisch ist.
Bitte nicht böse sein.
Liebe Grüße
Claudia
hier Beispiel Namen aus Liste erstellen
Tino
AW: hier Beispiel Namen aus Liste erstellen
Claudia
Hallo Tino,
das funktioniert Klasse. Kannst Du bei bei meinen anderen Punkten auch noch helfen?
In Spalte C würde ich gerne die mitzugebende Größe der Spalte eintragen. Steht nix, dann bleibt die Spaltengröße so.
Und ich hätte es gerne noch so, dass der Name aus der Spalte A dann auch in die Zeile 1 dieser betreffenden Spalte geschrieben würde.
Könntest Du weiterhin noch das Makro ab Zeile 20 im Reiter Blattnamen beginnen lassen. Da drüber steht noch was.
Ach so: In Deiner Beispieldatei wird der Spaltennamen immer überschrieben. Könntest Du da noch eine Plausi drauf bauen? Setze den Spaltennamen nicht, wenn die Spalte einen anderweitigen Namen hat. Und bitte noch in Spalte D dann den Status setzen.
Ich weiß, ich will immer zu viel. :-)
Vielen lieben Dank!
Liebe Grüße
Claudia
teste mal.
Tino
AW: teste mal. ---> noch Fehler
Claudia
Hallo Tino,
bei Deinem Makro kommt bei allen Einträgen "überprüfen" raus. Ich hatte vor dem Makrostart alle Spalten im zweiten Tabellenblatt gelöscht (denn bei mir in der Originaltabelle kam das gleiche Ergebnis raus). Da stimmt irgendwas noch nicht so ganz.
Könntest Du bitte mal schauen.
Liebe Grüße
Claudia
noch ein versuch...
Tino
AW: hier Beispiel Namen aus Liste erstellen
Josef
Hallo Claudia,
hier meine Version.
' **********************************************************************
' Modul: Modul6 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Enum CN_NAME_STATUS
CN_DONT_EXIST = -1
CN_NAME_EXISTS = 1
CN_REF_EXISTS = 2
End Enum
Public Function IsValidName(ByVal strName As String) As Boolean
Dim objRegExp As Object, rng As Range
If IsNumeric(Left(strName, 1)) Then Exit Function
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\%\&\$\§\(\)\[\]\{\}\s\t\r\n\f]{1,255}$"
.IgnoreCase = True
IsValidName = .test(strName)
End With
Set objRegExp = Nothing
End Function
Private Function checkName(ByVal strName As String, ByVal strRef As String, Optional ByRef WBook As Workbook) As CN_NAME_STATUS
Dim nName As Name
checkName = CN_DONT_EXIST
strRef = LCase(Replace(Replace(strRef, "$", ""), "=", ""))
If WBook Is Nothing Then Set WBook = ThisWorkbook
For Each nName In WBook.Names
If nName.Name = strName Then
If LCase(Replace(Replace(nName.RefersTo, "$", ""), "=", "")) = strRef Then
checkName = CN_NAME_EXISTS Or CN_REF_EXISTS
Else
checkName = CN_NAME_EXISTS
End If
Exit Function
End If
If LCase(Replace(Replace(nName.RefersTo, "$", ""), "=", "")) = strRef Then
If nName.Name = strName Then
checkName = CN_REF_EXISTS Or CN_NAME_EXISTS
Else
checkName = CN_REF_EXISTS
End If
Exit Function
End If
Next
End Function
Sub addNames()
Dim strName As String, strRef As String, strRange As String
Dim lngRow As Long, lngLast As Long, chkName As CN_NAME_STATUS
Dim objSh As Worksheet, rng As Range
With Sheets("Blattnamen")
On Error Resume Next
Set objSh = Sheets(.Index + 1)
On Error GoTo 0
If Not objSh Is Nothing Then
lngLast = Application.Max(20, .Cells(.Rows.Count, 1).End(xlUp).Row)
For lngRow = 20 To lngLast
If .Cells(lngRow, 1) <> "" And .Cells(lngRow, 2) <> "" Then
If IsValidName(.Cells(lngRow, 1)) Then
If IsNumeric(.Cells(lngRow, 3)) Then
If .Cells(lngRow, 3) > 0 Then
strRange = .Cells(lngRow, 2) & "1:" & .Cells(lngRow, 2) & .Cells(lngRow, 3)
Else
strRange = .Cells(lngRow, 2) & "1:" & .Cells(lngRow, 2) & .Rows.Count
End If
Else
strRange = .Cells(lngRow, 2) & ":" & .Cells(lngRow, 2)
End If
On Error Resume Next
Set rng = objSh.Range(strRange)
On Error GoTo 0
If Not rng Is Nothing Then
strRef = "=" & objSh.Name & "!" & rng.Address
strName = .Cells(lngRow, 1)
chkName = checkName(strName, strRef)
If chkName = CN_DONT_EXIST Then
ThisWorkbook.Names.Add strName, strRef
.Cells(lngRow, 4) = "OK"
objSh.Range(strRange).Cells(1, 1) = strName
Else
.Cells(lngRow, 4) = "Überprüfen"
End If
Else
.Cells(lngRow, 4) = "Ungültiger Bezug"
End If
Set rng = Nothing
Else
.Cells(lngRow, 4) = "Ungültiger Name"
End If
End If
Next
Else
MsgBox "Kein Blatt nach der Tabelle 'Blattnamen' !", vbExclamation, "Fehler"
End If
End With
End Sub
' Modul: Modul6 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Enum CN_NAME_STATUS
CN_DONT_EXIST = -1
CN_NAME_EXISTS = 1
CN_REF_EXISTS = 2
End Enum
Public Function IsValidName(ByVal strName As String) As Boolean
Dim objRegExp As Object, rng As Range
If IsNumeric(Left(strName, 1)) Then Exit Function
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\%\&\$\§\(\)\[\]\{\}\s\t\r\n\f]{1,255}$"
.IgnoreCase = True
IsValidName = .test(strName)
End With
Set objRegExp = Nothing
End Function
Private Function checkName(ByVal strName As String, ByVal strRef As String, Optional ByRef WBook As Workbook) As CN_NAME_STATUS
Dim nName As Name
checkName = CN_DONT_EXIST
strRef = LCase(Replace(Replace(strRef, "$", ""), "=", ""))
If WBook Is Nothing Then Set WBook = ThisWorkbook
For Each nName In WBook.Names
If nName.Name = strName Then
If LCase(Replace(Replace(nName.RefersTo, "$", ""), "=", "")) = strRef Then
checkName = CN_NAME_EXISTS Or CN_REF_EXISTS
Else
checkName = CN_NAME_EXISTS
End If
Exit Function
End If
If LCase(Replace(Replace(nName.RefersTo, "$", ""), "=", "")) = strRef Then
If nName.Name = strName Then
checkName = CN_REF_EXISTS Or CN_NAME_EXISTS
Else
checkName = CN_REF_EXISTS
End If
Exit Function
End If
Next
End Function
Sub addNames()
Dim strName As String, strRef As String, strRange As String
Dim lngRow As Long, lngLast As Long, chkName As CN_NAME_STATUS
Dim objSh As Worksheet, rng As Range
With Sheets("Blattnamen")
On Error Resume Next
Set objSh = Sheets(.Index + 1)
On Error GoTo 0
If Not objSh Is Nothing Then
lngLast = Application.Max(20, .Cells(.Rows.Count, 1).End(xlUp).Row)
For lngRow = 20 To lngLast
If .Cells(lngRow, 1) <> "" And .Cells(lngRow, 2) <> "" Then
If IsValidName(.Cells(lngRow, 1)) Then
If IsNumeric(.Cells(lngRow, 3)) Then
If .Cells(lngRow, 3) > 0 Then
strRange = .Cells(lngRow, 2) & "1:" & .Cells(lngRow, 2) & .Cells(lngRow, 3)
Else
strRange = .Cells(lngRow, 2) & "1:" & .Cells(lngRow, 2) & .Rows.Count
End If
Else
strRange = .Cells(lngRow, 2) & ":" & .Cells(lngRow, 2)
End If
On Error Resume Next
Set rng = objSh.Range(strRange)
On Error GoTo 0
If Not rng Is Nothing Then
strRef = "=" & objSh.Name & "!" & rng.Address
strName = .Cells(lngRow, 1)
chkName = checkName(strName, strRef)
If chkName = CN_DONT_EXIST Then
ThisWorkbook.Names.Add strName, strRef
.Cells(lngRow, 4) = "OK"
objSh.Range(strRange).Cells(1, 1) = strName
Else
.Cells(lngRow, 4) = "Überprüfen"
End If
Else
.Cells(lngRow, 4) = "Ungültiger Bezug"
End If
Set rng = Nothing
Else
.Cells(lngRow, 4) = "Ungültiger Name"
End If
End If
Next
Else
MsgBox "Kein Blatt nach der Tabelle 'Blattnamen' !", vbExclamation, "Fehler"
End If
End With
End Sub
Gruß Sepp
@ Sepp
Claudia
Hallo Sepp,
auch Dir danke ich für die Hilfe (mal wieder, das wird noch zu Gewohnheit, dass Du mir hilfst). :-)
Ich glaube, hier hast Du noch einen anfänglichen Stand, jedenfalls wird bei Deinem Makro nicht der Spaltennamen, sonder die Zelle 1 der jeweiligen Spalte geändert. Aber auch nicht immer.
Franz Lösung ist hier schon dicht am Ziel. Eine Kleinigkeit müsste noch geändert.
Aber auch Dir nochmals herzlichen Dank! Ich werde Deine Hilfe sicher nochmals benötigen. Solltest Du das Problem aber dennoch angehen wollen, dann schreibe ich Dir gerne kurz auf, wie der letzte Stand ist. Im "Wus" der Beiträge habe ich selbst die Orientierung verloren.
Liebe Grüße
Claudia
AW: Spalten definieren
fcs
Hallo Claudia,
das war dann schon ein größeres Mißverständnis.
Ich hoffe mit der folgenden Version funktioniert es nach deinen Vorstellungen.
Gruß
Franz
Sub SpaltenNamen()
Dim wksNamen As Worksheet, wksZiel As Worksheet
Dim objName As Name, bolName As Boolean
Dim strReferenz1 As String, strReferenz2 As String
Dim Zeile As Long, strName As String, strSpalte As String
On Error GoTo Fehler
Set wksNamen = Worksheets("Blattnamen")
Set wksZiel = Worksheets(wksNamen.Index + 1)
With wksNamen
For Zeile = 20 To .Cells(.Rows.Count, 1).End(xlUp).Row
strName = .Cells(Zeile, 1).Text
strSpalte = .Cells(Zeile, 2)
'prüfen, ob Spalte schon einen Namen hat
strReferenz1 = "=" & wksZiel.Name & "!" _
& wksZiel.Range(strSpalte & "1").EntireColumn.Address
strReferenz2 = "='" & wksZiel.Name & "'!" _
& wksZiel.Range(strSpalte & "1").EntireColumn.Address
bolName = True
For Each objName In Application.Names
If objName.RefersTo = strReferenz1 Or objName.RefersTo = strReferenz2 Then
If objName.Name = strName Then
bolName = True
Else
bolName = False
End If
Exit For
End If
Next
'Name erstellen und Bereich zuweisen, wenn Spalte noch keinen Namne hat
If bolName = True Then
Application.Names.Add Name:=strName, RefersTo:=strReferenz2
.Cells(Zeile, 4).Value = "ok"
Else
.Cells(Zeile, 4).Value = "prüfen"
End If
'Spaltentitel eintragen
wksZiel.Range(strSpalte & "1").Value = strName
'ggf. Spaltenbreite anpassen
If .Cells(Zeile, 3).Value > 0 Then
wksZiel.Range(strSpalte & "1").EntireColumn.ColumnWidth _
= .Cells(Zeile, 3).Value
End If
Next
End With
Fehler:
With Err
Select Case .Number
Case 0 'keinfehler
Case 1004 'Tritt auf, wenn Name nicht zulässig
strName = InputBox("Fehler-Nr.: " & .Number & vbLf & .Description & _
vbLf & vbLf & "Bitte Namen ändern", "Spalten Namen zuweisen - " _
& wksZiel.Name, strName)
If strName <> "" Then Resume
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, "Spalten Namen zuweisen - " & wksZiel.Name
End Select
End With
End Sub
@ Franz:
Claudia
Hallo Franz,
Dein Makro läuft hervorragend. Eine Bitte habe ich aber noch: Kannst Du das bitte noch so ändern, dass - wenn die Spalte bereits einen anderweitigen Namen als den zu vergebenen trägt, bei dieser Position ganz ausgestiegenen und in der nächsten Zeile fortgefahren wird,. Momenten müsste es so laufen, dass der Spaltenname zwar nicht eingetragen wird (daher status prüfen), aber in Zelle 1 wird er eingetragen und dei Größe wird auch eingestellt.
Mir wäre es lieber, wenn ich bei prüfen alles selber machen muss.
Ein großes dankeschön für die tolle Arbeit!
Liebe Grüße
Claudia
@ Franz: ---> offen vergessen
Claudia
Hallo Franz,
Dein Makro läuft hervorragend. Eine Bitte habe ich aber noch: Kannst Du das bitte noch so ändern, dass - wenn die Spalte bereits einen anderweitigen Namen als den zu vergebenen trägt, bei dieser Position ganz ausgestiegenen und in der nächsten Zeile fortgefahren wird,. Momenten müsste es so laufen, dass der Spaltenname zwar nicht eingetragen wird (daher status prüfen), aber in Zelle 1 wird er eingetragen und dei Größe wird auch eingestellt.
Mir wäre es lieber, wenn ich bei prüfen alles selber machen muss.
Ein großes dankeschön für die tolle Arbeit!
Liebe Grüße
Claudia
AW: @ Franz: ---> offen vergessen
fcs
Guten Morgen Claudia,
im folgenden Abschnitt des Makros muss du ein paar Zeilen verschieben, dann erfolgen Aktionen nur, wenn noch kein Name oder der gleiche Bereichsname der Spalte zugewiesen sind.
Gruß
Franz
Next
If bolName = True Then
'Name erstellen und Bereich zuweisen, wenn Spalte noch keinen Namne hat
Application.Names.Add Name:=strName, RefersTo:=strReferenz2
.Cells(Zeile, 4).Value = "ok"
'Spaltentitel eintragen
wksZiel.Range(strSpalte & "1").Value = strName
'ggf. Spaltenbreite anpassen
If .Cells(Zeile, 3).Value > 0 Then
wksZiel.Range(strSpalte & "1").EntireColumn.ColumnWidth _
= .Cells(Zeile, 3).Value
End If
Else
.Cells(Zeile, 4).Value = "prüfen"
End If
Next
End With
@Franz: vielen Dank !
Claudia
Dialog-Beispiele
Excel-Beispiele