Option Explicit
Enum ValType
SubjectName = 1
CityName = 2
BirthYear = 3
BirthPlace = 4
MotherName = 5
End Enum
' assort information in columns from rows
Sub exa()
Dim _
wksMunka2 As Worksheet, _
wksMunka3 As Worksheet, _
rngData As Range, _
rngFound As Range, _
aryRowMarker As Variant, _
aryRaw As Variant, _
aryOutput As Variant, _
RawVal As Variant, _
lFirstRow As Long, _
i As Long
'// Change to suit //
Const TOP_ROW_DATA As Long = 4
Const INPUT_COL As Long = 2
'// Set a reference to source and destination sheets. //
Set wksMunka2 = ThisWorkbook.Worksheets("Munka2")
Set wksMunka3 = ThisWorkbook.Worksheets("Munka3")
With wksMunka2
'// Set a reference to the range that has data, starting at the cell we //
'// prescribed, down to the last cell in the column that has data. If you have //
'// garbage that gets imported, you may use .Find instead to find last row with //
'// valid data. //
Set rngData = .Range(.Cells(TOP_ROW_DATA, INPUT_COL), _
.Cells(.Rows.Count, INPUT_COL).End(xlUp))
With rngData
'// See the function. Basically - find uppermost cell with FindWhat in it //
Set rngFound = RangeFound(SearchRange:=rngData, _
FindWhat:="<mezo=""name"">", _
StartingAfter:=rngData.Cells(rngData.Cells.Count), _
SearchUpDn:=xlNext)
'// If rngFound is Nothing, then we didn't find it - skip to Else and exit //
'// sub //
If Not rngFound Is Nothing Then
'// Save where we found the first match, so we know when we've searched //
'// the entire range and should stop looking. //
lFirstRow = rngFound.Row
'// Initially size our array of row numbers to hold the row number of //
'// the first match, and fill the element. //
ReDim aryRowMarker(1 To 1)
aryRowMarker(1) = lFirstRow
'// Loop using .FindNext, increasing the size of the array along the way//
'// and filling it with the row numbers until we find the first match //
'// again. //
Do
Set rngFound = .FindNext(After:=rngFound)
If Not rngFound.Row = lFirstRow Then
ReDim Preserve aryRowMarker(1 To UBound(aryRowMarker, 1) + 1)
aryRowMarker(UBound(aryRowMarker)) = rngFound.Row
End If
Loop While Not rngFound.Row = lFirstRow
'// Add one more element, this being the last row with data. Note that //
'// we 'push' it one row, as we'll drop a row from here on. //
ReDim Preserve aryRowMarker(1 To UBound(aryRowMarker) + 1)
aryRowMarker(UBound(aryRowMarker)) = rngData.Cells(rngData.Cells.Count).Row + 1
'// Size our output array based on how many row markers we saved for the//
'// rows, and of course 5 columns. Then fill the upper row with a //
'// header row. //
ReDim aryOutput(0 To UBound(aryRowMarker) - 1, 1 To 5)
aryOutput(0, 1) = "Name"
aryOutput(0, 2) = "City"
aryOutput(0, 3) = "Birth Year"
aryOutput(0, 4) = "POB"
aryOutput(0, 5) = "Mother Name"
'// Now we just run from the second row of the output array to the end //
For i = 1 To UBound(aryRowMarker) - 1
'// Using the row numbers saved, fill a dynamic array with the values//
'// in the given range. //
aryRaw = .Parent.Range(.Parent.Cells(aryRowMarker(i), INPUT_COL), _
.Parent.Cells(aryRowMarker(i + 1) - 1, INPUT_COL) _
).Value
'// For ea val in our 'chunk'... //
For Each RawVal In aryRaw
'// Return a val based on the first success of InStr, or, //
'// return Null. //
Select Case Switch(InStr(1, RawVal, "<mezo=""name"">") > 0, 1, _
InStr(1, RawVal, "<mezo=""city"">") > 0, 2, _
InStr(1, RawVal, "<mezo=""birth date"">") > 0, 3, _
InStr(1, RawVal, "<mezo=""birth place"">") > 0, 4, _
InStr(1, RawVal, "<mezo=""mother name"">") > 0, 5)
Case ValType.SubjectName
'// Trim up the found match and assign to correct element //
aryOutput(i, 1) = _
Replace( _
Replace(RawVal, "<mezo=""name"">", vbNullString), _
"</mezo>", vbNullString _
)
Case ValType.CityName
aryOutput(i, 2) = _
Replace( _
Replace(RawVal, "<mezo=""city"">", vbNullString), _
"</mezo>", vbNullString _
)
Case ValType.BirthYear
aryOutput(i, 3) = _
Replace( _
Replace(RawVal, "<mezo=""birth date"">", vbNullString), _
"</mezo>", vbNullString _
)
Case ValType.BirthPlace
aryOutput(i, 4) = _
Replace( _
Replace(RawVal, "<mezo=""birth place"">", vbNullString), _
"</mezo>", vbNullString _
)
Case ValType.MotherName
aryOutput(i, 5) = _
Replace( _
Replace(RawVal, "<mezo=""mother name"">", vbNullString), _
"</mezo>", vbNullString _
)
Case Else
'do nothing, garbage row
End Select
Next
Next
Else
Exit Sub
End If
End With
End With
'// plunk the output array where you want //
With wksMunka3.Range("A2").Resize(UBound(aryOutput, 1) + 1, 5)
.Value = aryOutput
.Rows(1).Font.Bold = True
.EntireColumn.AutoFit
End With
End Sub
Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function
Hope that helps,
Assort information in columns from rows
Reply With Quote
Originally Posted by hunsnowboard
