I have the dataset:
I want to iterate all columns and rows to select out the non-zero values and place it into a new sheet with the month:
Is it possible to achieve that using VBA or Vlookup?
My idea is:
For y in Item No Column
For x in Row
If Qty != 0, append to new sheet
Else go to the next cell
I am not very sure if it is achievable by VBA.
Thanks in advance!
This is for sure possible to do in VBA. I would suggest to save your data in three different Variant Arrays, one for your item numbers, one for your months and one for your quantities. You can read out the values like this:
dim quantities, months, numbers as Variant
quantities = range("YourQuantityRange")
months = range("YourMonthRange")
numbers = range("YourNumberRange")
Note that you have to replace the range values with rangs like "A2:A10" or whatever ranges you are using. I don't know where your values placed within your original sheet.
You also need to make a new sheet, you can do so like this
Dim mySheet As Worksheet
Set mySheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Then you can loop through your quantities Array like this and print the correct values to your second sheet if the number is not 0
dim i as Long, j as Long, rowCounter as Long
rowCounter = 2 'in which line do you want your first row of data to be written in the second sheet
For i = 1 To UBound(quantities, 1)
For j = 1 To UBound(quantities, 2)
if quantities(i, j) <> 0 then
mySheet.Cells(rowCounter, 1) = numbers(i,1) 'The second parameter of Cells() specifies the column so your item numbers will be pastet in the first column in this example
mySheet.Cells(rowCounter, 2) = quantities(i,j)
mySheet.Cells(rowCounter, 3) = months(1,j)
rowCounter = rowCounter + 1
end if
Next
Next
Note, this will place your values in the first, second and third column starting with the second row. You can for sure just edit the values to your needs.
Edited based on comment by Pᴇʜ
This is an Example of how to loop through your data using an array.
Option Explicit
Public Sub UnPivotData()
Dim wsSrc As Worksheet 'define source sheet
Set wsSrc = ThisWorkbook.Worksheets("Source")
Dim wsDest As Worksheet 'define output sheet
Set wsDest = ThisWorkbook.Worksheets("Destination")
Dim LastRow As Long 'find last used row
LastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
Dim LastCol As Long 'find last used column
LastCol = wsSrc.Cells(1, wsSrc.Columns.Count).End(xlToLeft).Column
Dim srcArr As Variant 'read data range into an array (makes it faster)
srcArr = wsSrc.Range("A1", wsSrc.Cells(LastRow, LastCol)).Value
Dim OutRow As Long 'find next free output row in destination sheet.
OutRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
Dim iRow As Long, iCol As Long
For iRow = 2 To UBound(srcArr) 'loop through all rows
For iCol = 3 To UBound(srcArr, 2) 'loop through month columns
If srcArr(iRow, iCol) <> 0 Then 'check if quantity is not 0
With wsDest.Cells(OutRow, 1) 'write everything
.Value = srcArr(iRow, 1)
.Offset(0, 1).Value = srcArr(iRow, iCol)
.Offset(0, 2).Value = srcArr(1, iCol)
End With
OutRow = OutRow + 1 'move to the next free row
'Debug.Print srcArr(iRow, 1), srcArr(iRow, iCol), srcArr(1, iCol)
End If
Next iCol
Next iRow
End Sub
Alternative if you want to use a even quicker way using an array for output too
Option Explicit
Public Sub UnPivotDataFastOutput()
Dim wsSrc As Worksheet 'define source sheet
Set wsSrc = ThisWorkbook.Worksheets("Source")
Dim LastRow As Long
LastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
Dim LastCol As Long
LastCol = wsSrc.Cells(1, wsSrc.Columns.Count).End(xlToLeft).Column
Dim srcArr As Variant 'read data range into an array
srcArr = wsSrc.Range("A1", wsSrc.Cells(LastRow, LastCol)).Value
Dim OutRow As Long
OutRow = 1
Dim destRowCount As Long 'calculate array size
destRowCount = Application.WorksheetFunction.CountIf(wsSrc.Range("C2", wsSrc.Cells(LastRow, LastCol)), "<>0")
Dim destArr As Variant
ReDim destArr(1 To destRowCount, 1 To 3)
Dim iRow As Long, iCol As Long
For iRow = 2 To UBound(srcArr)
For iCol = 3 To UBound(srcArr, 2)
If srcArr(iRow, iCol) <> 0 Then
'output into array
destArr(OutRow, 1) = srcArr(iRow, 1)
destArr(OutRow, 2) = srcArr(iRow, iCol)
destArr(OutRow, 3) = srcArr(1, iCol)
OutRow = OutRow + 1
'Debug.Print srcArr(iRow, 1), srcArr(iRow, iCol), srcArr(1, iCol)
End If
Next iCol
Next iRow
'write array into sheet
ThisWorkbook.Worksheets("Destination").Range("A2").Resize(destRowCount, 3).Value = destArr
End Sub
Try bellow.
Storing a one-to-one value in a cell has bad results. I do not know when the data is small, but it slows down when working with large amounts of data. I recommend that you have a habit of using a variant array.
Dim rstWs As Worksheet
Dim strSQL As String
Sub test()
Dim vDB As Variant, vR()
'vDB is static variant, vR() is Dynamic Variant
Dim Ws As Worksheet, toWs As Worksheet
Dim i As Long, j As Integer, n As Long
Dim r As Long, c As Integer
Dim wsName As String
Set Ws = ActiveSheet ' Sheets("Special Name")
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 2 To r
For j = 3 To c
If vDB(i, j) <> 0 Then
n = n + 1
ReDim Preserve vR(1 To 3, 1 To n) 'get data with Tranpose type
vR(1, n) = vDB(i, 1)
vR(2, n) = vDB(i, j)
vR(3, n) = vDB(1, j)
End If
Next j
Next i
Set toWs = Sheets.Add 'Sheets("Results")
With toWs
.UsedRange.Clear
.Range("a1").Resize(1, 3) = Array("Item No", "Qty", "Month")
.Range("a2").Resize(n, 3) = WorksheetFunction.Transpose(vR)
End With
Set rstWs = Sheets.Add
wsName = toWs.Name
strSQL = "Select [Item No], sum(Qty) as Qty "
strSQL = strSQL & "FROM [" & wsName & "$] "
strSQL = strSQL & "GROUP BY [Item No] "
DoSQL
End Sub
Sub DoSQL()
Dim Rs As Object
Dim strConn As String
Dim i As Integer
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 12.0;"
Set Rs = CreateObject("ADODB.Recordset")
Rs.Open strSQL, strConn
If Not Rs.EOF Then
With rstWs
.Range("a1").CurrentRegion.ClearContents
For i = 0 To Rs.Fields.Count - 1
.Cells(1, i + 1).Value = Rs.Fields(i).Name
Next
.Range("a" & 2).CopyFromRecordset Rs
End With
End If
Rs.Close
Set Rs = Nothing
End Sub
It is assumed that the data is as follows.
