Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Spalten definieren | Herbers Excel-Forum


Betrifft: Spalten definieren von: Claudia
Geschrieben am: 22.11.2009 18:20:29

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

  

Betrifft: AW: Spalten definieren von: fcs
Geschrieben am: 22.11.2009 19:11:33

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



  

Betrifft: AW: Spalten definieren von: Tino
Geschrieben am: 22.11.2009 19:12:26

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
Gruß Tino


  

Betrifft: AW: Spalten definieren von: Claudia
Geschrieben am: 22.11.2009 19:38:03

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


  

Betrifft: hier Beispiel Namen aus Liste erstellen von: Tino
Geschrieben am: 22.11.2009 19:55:00

Hallo,
habe noch etwas daran gebastelt.

https://www.herber.de/bbs/user/66093.xls

Gruß Tino


  

Betrifft: AW: hier Beispiel Namen aus Liste erstellen von: Claudia
Geschrieben am: 22.11.2009 20:01:49

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


  

Betrifft: teste mal. von: Tino
Geschrieben am: 22.11.2009 20:34:48

Hallo,

https://www.herber.de/bbs/user/66096.xls

Bin erst morgen wieder hier.

Gruß Tino


  

Betrifft: AW: teste mal. ---> noch Fehler von: Claudia
Geschrieben am: 22.11.2009 21:46:16

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


  

Betrifft: noch ein versuch... von: Tino
Geschrieben am: 23.11.2009 06:59:26

Hallo,

https://www.herber.de/bbs/user/66101.xls


Gruß Tino


  

Betrifft: AW: hier Beispiel Namen aus Liste erstellen von: Josef Ehrensberger
Geschrieben am: 22.11.2009 22:20:49

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



Gruß Sepp



  

Betrifft: @ Sepp von: Claudia
Geschrieben am: 22.11.2009 22:38:29

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


  

Betrifft: AW: Spalten definieren von: fcs
Geschrieben am: 22.11.2009 20:42:31

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



  

Betrifft: @ Franz: von: Claudia
Geschrieben am: 22.11.2009 22:33:47

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


  

Betrifft: @ Franz: ---> offen vergessen von: Claudia
Geschrieben am: 22.11.2009 22:50:54

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


  

Betrifft: AW: @ Franz: ---> offen vergessen von: fcs
Geschrieben am: 23.11.2009 08:13:58

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



  

Betrifft: @Franz: vielen Dank ! von: Claudia
Geschrieben am: 23.11.2009 11:02:43




Beiträge aus den Excel-Beispielen zum Thema "Spalten definieren"