Textboxes füllen - VBA | HERBERS Excel Forum

Hallo*
ich habe untenstehenden Code auszugsweise kopiert. Er soll bewirken, dass der Text, der sich unterhalb der Überschrift in Zeile 2 befindet, in eine Textbox genommen wird. Manchmal passiert es aber, dass der gesuchte Text, in diesem Fall die Lieferantennummer sich zwei bis drei Zellen daneben befindet. Ist es möglich, den Code so zu gestalten, dass der Text (in diesem Fall folgendes Format: drei Zahlen, ein Buchstabe, sechs Zahlen - z.B. 123Y456789) automatisch anhand des Formates gesucht wird und dann die Zellen soweit verschoben werden (nach links), dass der LieferNr. sich wieder unter der passenden Überschrift "LieferNr" befindet? Ich danke schon jetzt Allen für die Rückmeldung.
Herzliche Grüße
Wolfgang
Option Explicit
Dim active_xSheet As Worksheet


Sub Textboxes_fuellen()
Dim mySheet As Worksheet
Dim rng As Range
Set mySheet = ThisWorkbook.Worksheets(x_Sheet)
With mySheet
Set rng = .Rows(1).Find("LieferNr", LookAt:=xlWhole)
If Not rng Is Nothing Then
txtLiefernr.Text = rng.Offset(1, 0).Text
End If
'Wie könnte es hier weitergehen?
'Die weitere Abfrage soll bewirken, dass in Zeile 2 nach einer Nummer mit 'untenstehendem Format gesucht wird und diese dann in die Textbox übernommen wird.
'Es gibt im Tabellenblatt immer nur eine Nummer mit untenstehendem Format, die 'aber nicht immer unter der Überschrift zu finden ist
'und manchmal leider zwei bis drei Zellen daneben steht. Ist möglich, dann in 'der Folge die Zellen nach links zu verschieben, bis dann die LieferNr.
'auch unter der Überschrift LieferNr. zu finden ist?
If Not rng Like "###[A-Z]######" Then
End With
Set rng = Nothing
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Textboxes_fuellen() Dim mySheet As Worksheet Dim rng As Range Dim i As Integer Set mySheet = ThisWorkbook.Worksheets(x_Sheet) With mySheet Set rng = .Rows(1).Find("LieferNr", LookAt:=xlWhole) If Not rng Is Nothing Then 'LieferNummer suchen und unter die Überschrift setzen For i = 0 To 3 If CheckLieferNr(rng.Offset(1, i)) = True Then rng.Offset(1, 0) = rng.Offset(1, i) If i <> 0 Then rng.Offset(1, i).ClearContents Exit For End If Next i txtLiefernr.Text = rng.Offset(1, 0).Text End If End With Set rng = Nothing End Sub Private Function CheckLieferNr(LieferNr As String) As Boolean 'Prüft LieferNr auf Format "NNNANNNNNN" Dim i As Integer CheckLieferNr = True If Len(LieferNr) <> 10 Then CheckLieferNr = False Exit Function Else For i = 1 To 10 'Position der Zeichen in der Liefer-Nr. Select Case i Case 1 To 3, 5 To 10 'Diese Zeichen müssen nummerisch sein If Not (Asc(Mid(LieferNr, i, 1)) >= 48 And Asc(Mid(LieferNr, i, 1)) <= 57) Then CheckLieferNr = False Exit Function End If Case 4 'Dieses Zeichen muss ein Großbuchstabe (A-Z) sein If Not (Asc(Mid(LieferNr, i, 1)) >= 65 And Asc(Mid(LieferNr, i, 1)) <= 90) Then CheckLieferNr = False Exit Function End If Case Else 'do Nothing End Select Next i End If End Function

Sub Textboxes_fuellen() Dim mySheet As Worksheet Dim rng As Range Dim i As Integer, Anzahl As Integer Set mySheet = ThisWorkbook.Worksheets(x_Sheet) With mySheet Set rng = .Rows(1).Find("LieferNr", LookAt:=xlWhole) If Not rng Is Nothing Then 'LieferNummer suchen und zusammen mit den Nachbarzellen unter die Überschriften setzen For i = 0 To 3 If CheckLieferNr(rng.Offset(1, i)) = True And i <> 0 Then 'Anzahl der Zellen in Zeile 2 ermitteln, die nach links verschoben werden müssen Anzahl = .Cells(2, .Columns.Count).End(xlToLeft).Column - rng.Column - i + 1 'Zellen ausschneiden und verschieben rng.Offset(1, i).Range(Cells(1, 1), Cells(1, Anzahl)).Cut Destination:=rng.Offset(1, 0) Exit For End If Next i txtLiefernr.Text = rng.Offset(1, 0).Text End If End With Set rng = Nothing End Sub

Sub Textboxes_fuellen() Dim mySheet As Worksheet Dim rng As Range Dim i As Integer, Anzahl As Integer Set mySheet = ThisWorkbook.Worksheets(x_Sheet) With mySheet Set rng = .Rows(1).Find("LieferNr", LookAt:=xlWhole) If Not rng Is Nothing Then 'LieferNummer suchen und zusammen mit den Nachbarzellen unter die Überschriften setzen For i = 0 To 3 If CheckLieferNr(rng.Offset(1, i)) = True And i <> 0 Then 'Anzahl der Zellen in Zeile 2 ermitteln, die nach links verschoben werden müssen Anzahl = 4 'Zellen ausschneiden und verschieben rng.Offset(1, i).Range(Cells(1, 1), Cells(1, Anzahl)).Cut Destination:=rng.Offset(1, 0) Exit For End If Next i txtLiefernr.Text = rng.Offset(1, 0).Text End If End With Set rng = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Textboxes füllen - VBA

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

176 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Textboxes füllen - VBA

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

176 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread