Option Explicit
Sub Indices_maker()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
'Set source workbook
Set wb = Workbooks.Open(vFile, True, True) ' Open the source file.
Application.ScreenUpdating = False
'Set reads and writes
Dim shRead As Worksheet, shWrite, shWrite2 As Worksheet
Set shRead = wb.Worksheets("Indices")
Set shWrite = ThisWorkbook.Worksheets("Headers")
Set shWrite2 = ThisWorkbook.Worksheets("Values")
'Calcualte once manually
Application.Calculate
'Copy get number of indices
Dim iRowsCount As Integer ' Get the total Used Range rows in the source file.
iRowsCount = wb.Worksheets("Indices").UsedRange.Rows.Count
'for now i dont need column number:
'Dim iColumnsCount As Integer ' Get the total Columns in the source file.
'iColumnsCount = src.Worksheets("sheet1").UsedRange.Columns.Count
Dim iRows, iCols, iStartRow, StartPasteRow, KPIID As Integer
Dim Department, D_ID, KPIName, Category, CategoryID, YearNum As String
Dim DIDTable, KPIInfo, Comp As Range
Set DIDTable = ThisWorkbook.Worksheets("Tables").ListObjects("DeptIDtable").Range
Set KPIInfo = ThisWorkbook.Worksheets("Tables").ListObjects("KPIsinfo").Range
ThisWorkbook.Worksheets("Tables").Range("comps").NumberFormat = "@"
Set Comp = ThisWorkbook.Worksheets("Tables").Range("comps")
YearNum = ThisWorkbook.Worksheets("Tables").Range("A2").Value
iStartRow = 2
StartPasteRow = 0
'_________________Create Headers________________
'clear destination Headers sheet
shWrite.Rows("2:" & Rows.Count).ClearContents
[COLOR=rgb(147, 101, 184)] ' Now, read the index sheet from mastersheet and copy data to the Headers sheet, change 140 to iRowsCount when done testing
For iRows = 0 To 140[/COLOR]
If WorksheetFunction.IsText(shRead.Cells(iRows + iStartRow, 1)) = True Then
Department = shRead.Cells(iRows + iStartRow, 1).Value
D_ID = Application.VLookup(Department, DIDTable, 2, False)
KPIID = shRead.Cells(iRows + iStartRow, 2).Value
Category = Application.VLookup(KPIID, KPIInfo, 4, False)
CategoryID = Application.VLookup(KPIID, KPIInfo, 5, False)
KPIName = Application.VLookup(KPIID, KPIInfo, 6, False)
' copy department name
shRead.Cells(iRows + iStartRow, 1).Copy
'fill KPI values
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 1), shWrite.Cells(StartPasteRow + iStartRow + 15, 1)).PasteSpecial Paste:=xlPasteValues
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 2), shWrite.Cells(StartPasteRow + iStartRow + 15, 2)) = D_ID
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 3), shWrite.Cells(StartPasteRow + iStartRow + 15, 3)) = Category
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 4), shWrite.Cells(StartPasteRow + iStartRow + 15, 4)) = CategoryID
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 5), shWrite.Cells(StartPasteRow + iStartRow + 15, 5)) = KPIName
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 6), shWrite.Cells(StartPasteRow + iStartRow + 15, 6)) = KPIID
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 7), shWrite.Cells(StartPasteRow + iStartRow + 15, 7)) = YearNum
'fill component values
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 8), shWrite.Cells(StartPasteRow + iStartRow + 15, 8)).Formula = Comp.Value
shWrite.Range(shWrite.Cells(StartPasteRow + iStartRow, 8), shWrite.Cells(StartPasteRow + iStartRow + 15, 8)).NumberFormat = "@"
StartPasteRow = StartPasteRow + 16
End If
Next iRows
'iStartRow = iRows + 1
iRows = 0
'_________________Create Values________________
'clear destination Headers sheet
shWrite2.Rows("2:" & Rows.Count).ClearContents
' Now, read the index sheet from mastersheet and copy data to the Values sheet
Dim Comps_num As Integer
Dim CompV, CompVW, chkblank As Range
iStartRow = 2
StartPasteRow = 0
[COLOR=rgb(147, 101, 184)] ' Now, read the index sheet from mastersheet and copy data to the values sheet, change 140 to iRowsCount when done testing
For iRows = 0 To 140[/COLOR]
If WorksheetFunction.IsText(shRead.Cells(iRows + iStartRow, 1)) = True Then
Department = shRead.Cells(iRows + iStartRow, 1).Value
Comps_num = shRead.Cells(iRows + iStartRow + 1, 1).Value
D_ID = Application.VLookup(Department, DIDTable, 2, False)
KPIID = shRead.Cells(iRows + iStartRow, 2).Value
Category = Application.VLookup(KPIID, KPIInfo, 4, False)
CategoryID = Application.VLookup(KPIID, KPIInfo, 5, False)
KPIName = Application.VLookup(KPIID, KPIInfo, 6, False)
' copy department name
shRead.Cells(iRows + iStartRow, 1).Copy
'fill KPI values
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 1), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 1)).PasteSpecial Paste:=xlPasteValues
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 2), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 2)) = D_ID
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 3), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 3)) = Category
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 4), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 4)) = CategoryID
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 5), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 5)) = KPIName
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 6), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 6)) = KPIID
'[COLOR=rgb(84, 172, 210)]original copy paste
'shRead.Range(shRead.Cells(iRows + iStartRow + 1, 3), shRead.Cells(iRows + iStartRow + 1 + Comps_num, 18)).Copy
'shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 7), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 22)).PasteSpecial Paste:=xlPasteFormats
'shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 7), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 22)).PasteSpecial Paste:=xlPasteValues[/COLOR]
[COLOR=rgb(97, 189, 109)] ' with trim
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 7), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 22)).NumberFormat = "@"
shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 7), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 22)).NumberFormat = Trim(shRead.Range(shRead.Cells(iRows + iStartRow + 1, 3), shRead.Cells(iRows + iStartRow + 1 + Comps_num, 18)).Text)
Trim(shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 7), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 22)).NumberFormat).Text[/COLOR]
'replace blanks with -
Set CompVW = shWrite2.Range(shWrite2.Cells(StartPasteRow + iStartRow, 7), shWrite2.Cells(StartPasteRow + iStartRow + Comps_num, 22))
CompVW.Replace "", "-", xlWhole
StartPasteRow = StartPasteRow + Comps_num + 1
End If
Next iRows
iRows = 0
' Close the source file.
wb.Close False ' False, so you don't save the source file.
Set wb = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub