Macro Help

[joeserrone]

Hello Everyone:
I'm trying to format my data in a specific way, attached is the spreadsheet that contains the initial data and then the formatted template. Sheet1 is the raw data and I need to get it in a format similar to Sheet2.

Any help would be greatly appreciated.

Thanks

 

[HaHoBe]

Hi, Joe,

to get the total volume you could use a pivottable to deliver the data. Sorry, no good idea yet for the Evaluation.

Do you really just want the frst 4 items listed or go as long as there are different ones?

Ciao,
Holger

 

[joeserrone]

Hi HaHoBe, I actually need to go as long as there are different dates in the first Worksheet

Let me know if you can think of anything....

Thanks

 

[HaHoBe]

Hi, Joe,

no formatting applied by now (and no error handling), only a new sheet added with the data (hopefully ).

Private Sub FindUniqueItems(UniqueItems As Variant, FilterRange As String)
' returns a list containing all unique items in the filter range

Dim TempList() As String
Dim UniqueCount As Long
Dim cl As Range
Dim lngCount As Long

Range(FilterRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
UniqueCount = Range(FilterRange).SpecialCells(xlCellTypeVisible).Count
ReDim TempList(1 To UniqueCount - 1)

lngCount = 0

For Each cl In Range(FilterRange).SpecialCells(xlCellTypeVisible)
    lngCount = lngCount + 1
    If lngCount > 1 Then TempList(lngCount - 1) = cl.Formula ' ignore the heading
Next cl

Set cl = Nothing
UniqueItems = TempList

End Sub
 
Sub joeserrone()

'based on: ERLANDSEN DATA CONSULTING, http://www.erlandsendata.no/downloads/filterandprint.zip

Dim TaskList As Variant
Dim SiteList As Variant
Dim DayList As Variant
Dim lngCounter As Long
Dim wsNew As Worksheet
Dim lngLastRow As Long
Dim lngDayCount As Long
Dim lngSiteCount As Long
Dim rngTaskFound As Range
Dim rngSiteFound As Range
Dim rngDayFound As Range
 
Application.ScreenUpdating = False
Set wsNew = Worksheets.Add(after:=Worksheets(Worksheets.Count))

Sheets("Sheet1").Activate
lngLastRow = Cells(Rows.Count, "C").End(xlUp).Row

FindUniqueItems TaskList, Range("C1:C" & lngLastRow).Address
ActiveSheet.ShowAllData
 
For lngCounter = 1 To UBound(TaskList)
  wsNew.Cells(lngCounter + 3, "A") = TaskList(lngCounter)
Next lngCounter

FindUniqueItems DayList, Range("A1:A" & lngLastRow).Address
ActiveSheet.ShowAllData

FindUniqueItems SiteList, Range("B1:B" & lngLastRow).Address
ActiveSheet.ShowAllData
  
For lngDayCount = 1 To UBound(DayList)
  wsNew.Cells(1, 2 + (lngDayCount - 1) * 6).Value = DayList(lngDayCount)
  For lngSiteCount = 1 To UBound(SiteList)
    wsNew.Cells(2, 2 * lngSiteCount + (lngDayCount - 1) * 6) = SiteList(lngSiteCount)
    wsNew.Cells(3, 2 * lngSiteCount + (lngDayCount - 1) * 6) = "Volume"
    wsNew.Cells(3, 2 * lngSiteCount + 1 + (lngDayCount - 1) * 6) = "Evaluation"
  Next lngSiteCount
Next lngDayCount

For lngCounter = 2 To lngLastRow
  With wsNew
    Set rngTaskFound = .Columns("A:A").Find(Cells(lngCounter, "C"))
    Set rngDayFound = .Rows("1:1").Find(Cells(lngCounter, 1))
    Set rngSiteFound = .Range(.Cells(2, 1), .Cells(2, Columns.Count)).Find(Cells(lngCounter, 2))
    .Cells(rngTaskFound.Row, rngSiteFound.Column + rngDayFound.Column - 2).Value = Cells(lngCounter, "D").Value
    .Cells(rngTaskFound.Row, rngSiteFound.Column + rngDayFound.Column - 1).Value = Cells(lngCounter, "E").Value
  End With
Next lngCounter
wsNew.UsedRange.EntireColumn.AutoFit

Set rngSiteFound = Nothing
Set rngDayFound = Nothing
Set rngTaskFound = Nothing
Set wsNew = Nothing
Application.ScreenUpdating = True
 
End Sub

Ciao,
Holger