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