Alter dict de-pivot code to post back range

[Tim Hanson]

Hello,

I have a macro written by @Chihiro and slightly altered by @Hui here:
http://forum.chandoo.org/threads/alter-de-pivot-code-from-a-different-thread.35569/#post-212946

It de-pivots my raw data into a long list, I realize that it would do a great job of getting a range with conditions into an array

In this instance, I want that if any cell in column 2 is empty then remove the entire row, or do not add the row in the first place

For j = 2 To UBound(srcArr, 2)
          If srcArr(i, 2) <> "" Then
            .Item(kStr & "^" & srcArr(1, j) & "^" & srcArr(i, j)) = 1
          End If
        Next

But I do not know how to alter this part so that it does not de-pivot but instead has the range with the rows removed

 ReDim resArr(1 To .Count, 1 To 4)
  i = 1
  For Each Key In .Keys
  x = Split(Key, "^")
  For j = 0 To UBound(x)
  resArr(i, j + 1) = x(j)
  Next
  i = i + 1
  Next

I hope I was clear, I have uploaded a file

Thanks for any help on this

Sub Test()
Dim srcArr, resArr, Key, x
Dim i As Long, j As Long
Dim kStr As String
Dim sTime As Single, eTime As Double
sTime = Timer

Sheets("Get").Range("A1").CurrentRegion.clearcontents

With Sheets("RawData")
    srcArr = .Range(.Cells(1, "A"), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).value
End With

With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(srcArr)
        For j = 1 To 1
            kStr = IIf(Len(kStr) = 0, srcArr(i, j), kStr & "^" & srcArr(i, j))
        Next
     
        For j = 2 To UBound(srcArr, 2)
          If srcArr(i, 2) <> "" Then
            .Item(kStr & "^" & srcArr(1, j) & "^" & srcArr(i, j)) = 1
          End If
        Next
     
        kStr = ""
    Next
 
    ReDim resArr(1 To .Count, 1 To 4)
    i = 1
    For Each Key In .keys
        x = Split(Key, "^")
        For j = 0 To UBound(x)
            resArr(i, j + 1) = x(j)
        Next
        i = i + 1
    Next
End With

Sheets("Get").Range("A2").Resize(UBound(resArr), 3) = resArr

eTime = Timer
Debug.Print eTime - sTime
End Sub

 

[Tim Hanson]

Sorry about my awful question, I think it only showed my lack of understanding of the code I posted

I did get this to work, if you can see any way to tighten or improve it I would appreciate any comments

Thanks

Sub arrT()
Dim srcArr, newArr, desArr
Dim i As Long, irow As Long, icol As Long
Dim sTime As Single, eTime As Double

sTime = Timer

    srcArr = Sheets("RawData").UsedRange.Value2
    ReDim newArr(LBound(srcArr, 1) To UBound(srcArr, 1), LBound(srcArr, 2) To UBound(srcArr, 2))
  
    irow = 0
    For i = LBound(srcArr, 1) To UBound(srcArr, 1)
      If srcArr(i, 3) <> "" Then
        irow = irow + 1
        For icol = LBound(srcArr, 2) To UBound(srcArr, 2)
          newArr(irow, icol) = srcArr(i, icol)
        Next icol
      End If
    Next i
    desArr = Application.WorksheetFunction.Transpose(newArr)
    ReDim Preserve desArr(LBound(newArr, 2) To UBound(newArr, 2), LBound(newArr, 1) To irow)
  
    newArr = Application.WorksheetFunction.Transpose(desArr)
    Sheets("Get").Range("A1").Resize(irow, UBound(srcArr, 2)).Value = newArr


eTime = Timer
Debug.Print eTime - sTime
End Sub