Sub XcaliburLongReportNewWorkbookKlaas()
'
' XcaliburLongReportNewWorkbookKlaas Macro
' Bundeling Xcalibur Long Report in nieuw venster - 18/11/2013 - Klaas Schoutteten
' Updated for Excel 2013 compatibility on 7/7/2015 (Line 26)
'

Dim DataWB As Workbook
Dim NewWB As Workbook
Dim DataWSAmount As Integer
Dim DataWBSheet1 As Worksheet
Dim NewWBSheet1 As Worksheet
Dim NewWBSheet2 As Worksheet

Dim ComponentRow As Integer
Dim ComponentColumn As Integer
Dim AreaColumn As Integer
Dim ISTDAreaColumn As Integer
Dim CalcAmtColumn As Integer


'Assign reference to Quan Long Export workbook
Set DataWB = Application.Workbooks(1)                                       'DataWB = Quan Long Export
'Create and assign new workbook for the Summary
Set NewWB = Application.Workbooks.Add                                       'NewWB = Summary
Application.Worksheets.Add
'Count the amount of worksheets in the Quan Long Export workbook
DataWSAmount = DataWB.Worksheets.Count - 1

'Assign reference to first worksheet in the Quan Long Export workbook and to first and second worksheet in the NewWB
Set DataWBSheet1 = DataWB.Worksheets(1)
Set NewWBSheet1 = NewWB.Worksheets(1)
Set NewWBSheet2 = NewWB.Worksheets(2)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Copy Extended version

'Copy Column Headers (Sample Name, Area, ISTD Area, Calc Conc) from first worksheet and paste in the NewWB
NewWBSheet1.Cells(3, 1).Value = DataWBSheet1.Cells(5, 3).Value              'Sample Name header

'Copy all sample names from first row (row 6) to end
    'Have x start at row 6
    x = 6                                                                   'x = number of row
    'Loop until a blank row is found
    Do While DataWBSheet1.Cells(x, 1).Value <> ""
    'Copy sample names
    NewWBSheet1.Cells(x - 2, 1).Value = DataWBSheet1.Cells(x, 3).Value      'actual sample name
    x = x + 1
    Loop

'For every worksheet(i) loop
For i = 1 To DataWSAmount
    'Assign row- and columnnumbers
    HeaderRow = 2                                                           'Header Row is 2
    ComponentColumn = 1 + (4 * (i - 1))                                     'Component Name column schuift telkens 4 op
    AreaColumn = 2 + (4 * (i - 1))                                          'Area column
    ISTDAreaColumn = 3 + (4 * (i - 1))                                      'ISTD Area column
    CalcAmtColumn = 4 + (4 * (i - 1))                                       'Calc Amt column
    'Copy the component names
    NewWBSheet1.Cells(HeaderRow, ComponentColumn + 1).Value = DataWB.Sheets(i).Cells(3, 1).Value    'Component Name
    
    'Copy the Area, ISTD Area and Calc Amt columns
        'Have y start at row 5 to include the column headers
        y = 5                                                               'y = number of Row
        Do While DataWBSheet1.Cells(y, 1).Value <> ""
        NewWBSheet1.Cells(y - 2, AreaColumn).Value = DataWB.Sheets(i).Cells(y, 15).Value            'Area column
        NewWBSheet1.Cells(y - 2, ISTDAreaColumn).Value = DataWB.Sheets(i).Cells(y, 17).Value        'ISTD Area column
        NewWBSheet1.Cells(y - 2, CalcAmtColumn).Value = DataWB.Sheets(i).Cells(y, 6).Value          'Calc Amt column
        y = y + 1
        Loop
Next

'Layout adjustment
NewWBSheet1.Activate
    'Arial size 8
    NewWBSheet1.Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
    End With
    'Row Component Name bold
    NewWBSheet1.Rows(2).Select
    With Selection.Font
        .Bold = True
    End With
    'Row Headers Bold
    NewWBSheet1.Rows(3).Select
    With Selection.Font
        .Bold = True
    End With
    'Column Sample Names Auto-width fit
    NewWBSheet1.Columns("A").AutoFit
    'Round to 2 decimals
    NewWBSheet1.Cells.Select
    Selection.NumberFormat = "0.00"
    NewWBSheet1.Cells(1, 1).Select
'Rename worksheet 1 and 2
NewWBSheet1.Name = "Extended"

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Copy Short version

'Copy Column Headers (Sample Name, Area, ISTD Area, Calc Conc) from first worksheet and paste in the NewWB
NewWBSheet2.Cells(3, 1).Value = DataWBSheet1.Cells(5, 3).Value              'Sample Name header

'Copy all sample names from first row (row 6) to end
    'Have x start at row 6
    x = 6                                                                   'x = number of row
    'Loop until a blank row is found
    Do While DataWBSheet1.Cells(x, 1).Value <> ""
    'Copy sample names
    NewWBSheet2.Cells(x - 2, 1).Value = DataWBSheet1.Cells(x, 3).Value      'actual sample name
    x = x + 1
    Loop

'For every worksheet(i) loop
For i = 1 To DataWSAmount
    'Assign row- and columnnumbers
    HeaderRow = 2                                                           'Header Row is 2
    ComponentColumn = 1 + (1 * (i - 1))                                     'Component Name column schuift telkens 4 op
    CalcAmtColumn = 2 + (1 * (i - 1))                                       'Calc Amt column
    'Copy the component names
    NewWBSheet2.Cells(HeaderRow + 1, ComponentColumn + 1).Value = DataWB.Sheets(i).Cells(3, 1).Value    'Component Name
    
    'Copy the Calc Amt column
        'Have y start at row 6, without including the column header
        y = 6                                                               'y = number of Row
        Do While DataWBSheet1.Cells(y, 1).Value <> ""
        NewWBSheet2.Cells(y - 2, CalcAmtColumn).Value = DataWB.Sheets(i).Cells(y, 6).Value          'Calc Amt column
        y = y + 1
        Loop
Next

'Delete MeOH rows from the Short worksheet
NewWBSheet2.Activate
With ActiveSheet
    .AutoFilterMode = False
    With Range("A4", Range("A" & Rows.Count).End(xlUp))
        .AutoFilter 1, "MeOH"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
End With

'Delete ISTD columns from the Short worksheet
    'atrazine-d5
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "atrazine-d5") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'diatrizoic_acid-d6
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "diatrizoic_acid-d6") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'diuron-d6
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "diuron-d6") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'ibuprofen-d3
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "ibuprofen-d3") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'ketoprofen-d3
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "ketoprofen-d3") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'metoprolol-d7
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "metoprolol-d7") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'MPFOS
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "MPFOS") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'paracetamol-d4
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "paracetamol-d4") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x
    'sulfamethoxazole-13C6
    NewWBSheet2.Activate
    Set r = ActiveSheet.UsedRange.Resize(1)
    LC = r(r.Count).Column
    For x = LC To 1 Step -1
        If Application.CountIf(Columns(x), "sulfamethoxazole-13C6") > 0 Then
            Columns(x).EntireColumn.Delete
        End If
    Next x

'Layout adjustment
NewWBSheet2.Activate
    'Arial size 8
    NewWBSheet2.Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
    End With
    'Row Component Name bold
    NewWBSheet2.Rows(3).Select
    With Selection.Font
        .Bold = True
    End With
    'Column Sample Names Auto-width fit
    NewWBSheet2.Columns("A").AutoFit
    'Round to 2 decimals
    NewWBSheet2.Cells.Select
    Selection.NumberFormat = "0.00"
    NewWBSheet2.Cells(1, 1).Select
'Rename worksheet 2
NewWBSheet2.Name = "Short"

End Sub