Im creating a macro VBA excel for the first time.
I have the table that contains 4 columns as follows:
Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 396035:835253:907794
And I want to separate them so that the output is:
Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 396035 Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 835253 Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 907794
The macro that I used is as follows (from references in stackoverflow) but I have a type mismatch error on line
[e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y)
Any help would be really appreciated. This is my first time dealing with VBA and it seems pretty blank to me about the type mismatch.
Sub SliceNDice() Dim objRegex As Object Dim X Dim Y Dim lngRow As Long Dim lngCnt As Long Dim tempArr() As String Dim strArr Set objRegex = CreateObject("vbscript.regexp") objRegex.Pattern = "^\s+(.+?)$" 'Define the range to be analysed X = Range([a1], Cells(Rows.Count, "d").End(xlUp)).Value2 ReDim Y(1 To 4, 1 To 1000) For lngRow = 1 To UBound(X, 1) 'Split each string by "," tempArr = Split(X(lngRow, 4), ",") For Each strArr In tempArr lngCnt = lngCnt + 1 'Add another 1000 records to resorted array every 1000 records If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 4, 1 To lngCnt + 1000) Y(1, lngCnt) = X(lngRow, 1) Y(2, lngCnt) = X(lngRow, 2) Y(3, lngCnt) = X(lngRow, 3) Y(4, lngCnt) = objRegex.Replace(strArr, "$1") Next Next lngRow 'Dump the re-ordered range to columns E:H [e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y) ActiveSheet.Range("E:H").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _ Header:=xlNo End Sub
And my file is consists of hundred and thousands of rows.
Here is one way. Not the fastest but does the job. I have commented the code so you will not have a problem understanding it.
Sub Sample() Dim ws As Worksheet Dim lRow As Long, i As Long, j As Long Dim tmpAr As Variant '~~> Change this to the relevant sheet Set ws = ThisWorkbook.Sheets("Sheet1") With ws '~~> Get last row in Col D. That is where we have to check for ":" lRow = .Range("D" & .Rows.Count).End(xlUp).Row '~~> Reverse loop the rows For i = lRow To 1 Step -1 '~~> Check if cell in Col D has ":" If InStr(1, .Range("D" & i).Value, ":") Then '~~> Split on ":" and store in an array tmpAr = Split(.Range("D" & i).Value, ":") '~~> Loop through the array For j = LBound(tmpAr) To UBound(tmpAr) '~~> Insert a row in the next row .Rows(i + 1).Insert Shift:=xlDown, _ CopyOrigin:=xlFormatFromLeftOrAbove '~~> Copy data from above as cell in Col D is different .Rows(i).Copy .Rows(i + 1) '~~> Add the new value to cell in Col D .Cells(i + 1, 4).Value = tmpAr(j) Next j '~~> Delete the row .Rows(i).Delete End If Next i End With End Sub