String nachZahl durchsuchen und transponieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: String nachZahl durchsuchen und transponieren
von: chito
Geschrieben am: 18.06.2015 11:09:05

Hallo ins Forum,
ja ich bin es wieder und habe ein Problem, das für mich nicht einfach, aber für die Spezialisten hier bestimmt zu lösen ist.
Ich habe eine Webabfrage, die bis zu 250 Tabellen erzeugt, diese Tabellen sind immer gleich aufgebaut siehe Beispiel. Nun möchte ich den String in Zelle B3 auf die rot markierte Zahl selektieren und wenn die Zahl mit Tabelle "Auswertung1" ab Spalte A4
übereinstimmt dort ab Zelle J4 den Wert aus den anderen Tabellen Zellen C14 bis C104 transponieren.
Und das für alle Tabellen die durch die Webabfrage erzeugt worden sind.
Ich hoffe, das jemand mir dabei helfen kann.
https://www.herber.de/bbs/user/98283.xlsx
Gruß
chito

Bild

Betrifft: AW: String nachZahl durchsuchen und transponieren
von: Mullit
Geschrieben am: 18.06.2015 18:00:20
Hallo,
das geht vielleicht mit Regexp:

Option Explicit

Private Function fncRegexp(ByRef prwksSheet As Worksheet) As String
  Dim objRegEx As Object, objMatch As Object
  Dim strText As String
  Dim intIndex As Integer
  strText = prwksSheet.Cells(3, 2).Text
  Set objRegEx = CreateObject(Class:="vbscript.regexp")
  With objRegEx
      For intIndex = 1 To 2
          .Global = True
          .IgnoreCase = True
          .MultiLine = False
          .Pattern = IIf(Expression:=intIndex = 1, TruePart:="Empl ID \d+ Badge", FalsePart:="\d+")
          Set objMatch = .Execute(strText)
          strText = objMatch(0)
      Next
      fncRegexp = strText
  End With
  Set objRegEx = Nothing
  Set objMatch = Nothing
End Function

Public Sub prcTransposeData()
Const END_AREA As Long = 91
Const TARGET_COLUMN As Long = 10
Const TARGET_ROW As Long = 4
Const SOURCE_COLUMN As Long = 3
Const SOURCE_ROW As Long = 14
Const TARGET_SHEET As String = "Auswertung1"
Dim objCell As Range
Dim avntArray As Variant
Dim wksSheet As Worksheet
Application.ScreenUpdating = False
With ThisWorkbook
    With .Worksheets(TARGET_SHEET)
        With .Cells(TARGET_ROW, TARGET_COLUMN).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)
            Set objCell = .Find(What:="?", LookIn:=xlValues, LookAt:=xlPart)
            While Not objCell Is Nothing
                 With ThisWorkbook.Worksheets(TARGET_SHEET).Cells(objCell.Row, _
                     TARGET_COLUMN).Resize(1, END_AREA)
                     .Borders.LineStyle = xlNone
                     .Interior.Pattern = xlNone
                     .ClearContents
                 End With
                 Set objCell = .FindNext(After:=objCell)
            Wend
        End With
    End With
    For Each wksSheet In .Worksheets
        If wksSheet.Name <> TARGET_SHEET Then
             avntArray = wksSheet.Cells(SOURCE_ROW, SOURCE_COLUMN).Resize(END_AREA, 1).Value
             With .Worksheets(TARGET_SHEET)
                 Set objCell = .Cells(TARGET_ROW, 1).Resize(.Cells( _
                     .Rows.Count, 1).End(xlUp).Row, 1).Find( _
                   What:=fncRegexp$(prwksSheet:=wksSheet), LookIn:=xlValues, LookAt:=xlWhole)
                 If Not objCell Is Nothing Then
                    With .Cells(objCell.Row, TARGET_COLUMN).Resize(1, END_AREA)
                          With .Borders(xlEdgeLeft)
                               .LineStyle = xlContinuous
                               .Weight = xlThin
                          End With
                          With .Borders(xlEdgeTop)
                               .LineStyle = xlContinuous
                               .Weight = xlThin
                          End With
                          With .Borders(xlEdgeBottom)
                               .LineStyle = xlContinuous
                               .Weight = xlThin
                          End With
                          With .Borders(xlEdgeRight)
                               .LineStyle = xlContinuous
                               .Weight = xlThin
                          End With
                          With .Borders(xlInsideVertical)
                               .LineStyle = xlContinuous
                               .Weight = xlThin
                          End With
                          .Interior.Color = vbYellow
                          .Value = WorksheetFunction.Transpose(avntArray)
                    End With
                 End If
             End With
        End If
    Next
End With
Application.ScreenUpdating = True
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Gruß, Mullit

Bild

Betrifft: AW: String nachZahl durchsuchen und transponieren
von: chito
Geschrieben am: 18.06.2015 19:58:20
Hallo Mullit,
vielen Dank für den Code bekomme aber leider einen Fehler "Laufzeitfehler 5" im Code strText = objMatch(0)
und die Farben brauche ich auch nicht waren nur zur Information.
Gruß
Chito

Bild

Betrifft: AW: String nachZahl durchsuchen und transponieren
von: Mullit
Geschrieben am: 19.06.2015 01:15:25
Hallo chito,
werden denn überhaupt transponierte Zeilen bei Dir eingefügt..?
Wenn ja, hast Du bspw. entweder mehr Leerzeichen in Deinem Suchstring als angegeben, oder Dir fehlen irgendwo Deine Index-Nummern in den WebabfrageTabs, das müsste Dir hier angezeigt werden:

Option Explicit

Private Function fncRegexp(ByRef prwksSheet As Worksheet) As String
  Dim objRegEx As Object, objMatch As Object
  Dim strText As String
  Dim intIndex As Integer
  strText = prwksSheet.Cells(3, 2).Text
  Set objRegEx = CreateObject(Class:="vbscript.regexp")
  With objRegEx
      For intIndex = 1 To 2
          .Global = True
          .IgnoreCase = True
          .MultiLine = False
          .Pattern = IIf(Expression:=intIndex = 1, TruePart:="Empl ID \s*\d+\s* Badge", FalsePart:="\d+")
          Set objMatch = .Execute(strText)
          If objMatch.Count > 0 Then
            strText = objMatch(0)
          Else
            strText = vbNullString
          End If
      Next
      fncRegexp = strText
  End With
  Set objRegEx = Nothing
  Set objMatch = Nothing
End Function

Public Sub prcTransposeData()
Const END_AREA As Long = 91
Const TARGET_COLUMN As Long = 10
Const TARGET_ROW As Long = 4
Const SOURCE_COLUMN As Long = 3
Const SOURCE_ROW As Long = 14
Const TARGET_SHEET As String = "Auswertung1"
Dim objCell As Range
Dim avntArray As Variant
Dim wksSheet As Worksheet
Dim lngCount As Long
Dim strFncResult As String
Application.ScreenUpdating = False
With ThisWorkbook
    With .Worksheets(TARGET_SHEET)
        With .Cells(TARGET_ROW, TARGET_COLUMN).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)
            Set objCell = .Find(What:="?", LookIn:=xlValues, LookAt:=xlPart)
            While Not objCell Is Nothing
                 ThisWorkbook.Worksheets(TARGET_SHEET).Cells(objCell.Row, _
                     TARGET_COLUMN).Resize(1, END_AREA).ClearContents
                 Set objCell = .FindNext(After:=objCell)
            Wend
        End With
    End With
    For Each wksSheet In .Worksheets
        If wksSheet.Name <> TARGET_SHEET Then
             avntArray = wksSheet.Cells(SOURCE_ROW, SOURCE_COLUMN).Resize(END_AREA, 1).Value
             strFncResult = fncRegexp$(prwksSheet:=wksSheet)
             With .Worksheets(TARGET_SHEET)
                 Set objCell = .Cells(TARGET_ROW, 1).Resize(.Cells( _
                     .Rows.Count, 1).End(xlUp).Row, 1).Find( _
                   What:=strFncResult, LookIn:=xlValues, LookAt:=xlWhole)
                 If strFncResult = vbNullString Then _
                   lngCount = lngCount + 1
                 If Not objCell Is Nothing Then _
                   .Cells(objCell.Row, TARGET_COLUMN).Resize(1, END_AREA).Value = _
                       WorksheetFunction.Transpose(avntArray)
             End With
        End If
    Next
    Set objCell = Nothing
End With
If lngCount > 0 Then _
  MsgBox "Obacht: In  " & lngCount & _
    "  Webabfrage-Tabs fehlen die Indexnummern!", vbExclamation
Application.ScreenUpdating = True
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Andernfalls müsstest Du nochmals eine Bsp.-mappe mit dem Fehlercode hochladen und nochmal klären, ob der Suchstring exakt so aussieht wie angegeben.
Die Farben hab' ich übrigens rausgeschmissen...
Gruß, Mullit

Bild

Betrifft: AW: String nachZahl durchsuchen und transponieren
von: chito
Geschrieben am: 19.06.2015 08:07:36
Hallo Mullit,
vielen Dank, habe keine Ahnung warum, aber es funktioniert jetzt ohne Fehler.
Danke nochmal
chito

 Bild

Beiträge aus den Excel-Beispielen zum Thema "String nachZahl durchsuchen und transponieren"