Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1428to1432
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

String nachZahl durchsuchen und transponieren

String nachZahl durchsuchen und transponieren
18.06.2015 11:09:05
chito
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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: String nachZahl durchsuchen und transponieren
18.06.2015 18:00:20
Mullit
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

Anzeige
AW: String nachZahl durchsuchen und transponieren
18.06.2015 19:58:20
chito
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

AW: String nachZahl durchsuchen und transponieren
19.06.2015 01:15:25
Mullit
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

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

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige