I have a code below that needs to be tweaked, as I want to be able to enter my sheet name in an input box and have it reformat the sheet and output next to the sheet I select.
See formula I attempted but failed.
Sub Chart()
Dim wb As Workbook
Dim wsRaw As Worksheet, wsResult As Worksheet
Dim iRow As Byte, iCol As Byte, iResultRow As Byte, iRawCol As Byte
Dim Result As String
Result = InputBox("Provide a sheet name.")
Workbooks(wb).Sheets(Result).Select
Set wb = ThisWorkbook
Set wsRaw = Application.ActiveSheet
Set wsResult = Worksheets.Add(After:=Sheets(Worksheets.count))
iRow = 2
iResultRow = 2
Do Until wsRaw.Cells(iRow, 1) = Empty
wsResult.Cells(iResultRow, 1) = wsRaw.Cells(iRow, 1)
wsResult.Cells(iResultRow + 1, 1) = wsRaw.Cells(iRow, 1)
wsResult.Cells(iResultRow + 2, 1) = wsRaw.Cells(iRow, 1)
wsResult.Cells(iResultRow, 2) = wsRaw.Cells(iRow, 2)
wsResult.Cells(iResultRow + 1, 2) = wsRaw.Cells(iRow, 2)
wsResult.Cells(iResultRow + 2, 2) = wsRaw.Cells(iRow, 2)
wsResult.Cells(iResultRow, 3) = wsRaw.Cells(iRow, 3)
wsResult.Cells(iResultRow + 1, 3) = wsRaw.Cells(iRow, 3)
wsResult.Cells(iResultRow + 2, 3) = wsRaw.Cells(iRow, 3)
wsResult.Cells(iResultRow, 4) = wsRaw.Cells(iRow, 4)
wsResult.Cells(iResultRow + 1, 4) = wsRaw.Cells(iRow, 4)
wsResult.Cells(iResultRow + 2, 4) = wsRaw.Cells(iRow, 4)
wsResult.Cells(iResultRow, 5) = "Lender"
wsResult.Cells(iResultRow + 1, 5) = "All"
wsResult.Cells(iResultRow + 2, 5) = "Percent"
iRawCol = 5
iCol = 6
Do Until iCol = 46
wsResult.Cells(1, iCol) = Left(wsRaw.Cells(1, iRawCol), 9)
wsResult.Cells(iResultRow, iCol) = wsRaw.Cells(iRow, iRawCol)
wsResult.Cells(iResultRow + 1, iCol) = wsRaw.Cells(iRow, iRawCol + 1)
wsResult.Cells(iResultRow + 2, iCol) = wsRaw.Cells(iRow, iRawCol + 2)
iCol = iCol + 1
iRawCol = iRawCol + 3
Loop
iResultRow = iResultRow + 3
iRow = iRow + 1
Loop
Sheets("Macros").Select
End Sub
Sub Chart()
Dim wb As Workbook
Dim wsRaw As Worksheet, wsResult As Worksheet
Dim iRow As Byte, iCol As Byte, iResultRow As Byte, iRawCol As Byte
Dim Result As Worksheet, RangeResult As Range
Set wb = ThisWorkbook
Set ResultRange = Application.InputBox("Provide a sheet name.", Type:=8)
Set Result = ResultRange.Parent
wb.Result.Select
Set wsRaw = Application.ActiveSheet
Set wsResult = Worksheets.Add(After:=Sheets(Worksheets.Count))
iRow = 2
iResultRow = 2
Do Until wsRaw.Cells(iRow, 1) = Empty
wsResult.Cells(iResultRow, 1) = wsRaw.Cells(iRow, 1)
wsResult.Cells(iResultRow + 1, 1) = wsRaw.Cells(iRow, 1)
wsResult.Cells(iResultRow + 2, 1) = wsRaw.Cells(iRow, 1)
wsResult.Cells(iResultRow, 2) = wsRaw.Cells(iRow, 2)
wsResult.Cells(iResultRow + 1, 2) = wsRaw.Cells(iRow, 2)
wsResult.Cells(iResultRow + 2, 2) = wsRaw.Cells(iRow, 2)
wsResult.Cells(iResultRow, 3) = wsRaw.Cells(iRow, 3)
wsResult.Cells(iResultRow + 1, 3) = wsRaw.Cells(iRow, 3)
wsResult.Cells(iResultRow + 2, 3) = wsRaw.Cells(iRow, 3)
wsResult.Cells(iResultRow, 4) = wsRaw.Cells(iRow, 4)
wsResult.Cells(iResultRow + 1, 4) = wsRaw.Cells(iRow, 4)
wsResult.Cells(iResultRow + 2, 4) = wsRaw.Cells(iRow, 4)
wsResult.Cells(iResultRow, 5) = "Lender"
wsResult.Cells(iResultRow + 1, 5) = "All"
wsResult.Cells(iResultRow + 2, 5) = "Percent"
iRawCol = 5
iCol = 6
Do Until iCol = 46
wsResult.Cells(1, iCol) = Left(wsRaw.Cells(1, iRawCol), 9)
wsResult.Cells(iResultRow, iCol) = wsRaw.Cells(iRow, iRawCol)
wsResult.Cells(iResultRow + 1, iCol) = wsRaw.Cells(iRow, iRawCol + 1)
wsResult.Cells(iResultRow + 2, iCol) = wsRaw.Cells(iRow, iRawCol + 2)
iCol = iCol + 1
iRawCol = iRawCol + 3
Loop
iResultRow = iResultRow + 3
iRow = iRow + 1
Loop
Sheets("Macros").Select
End Sub
Related
I have the below code that works fine, however i am trying to amend th code to no avail so that it saves the files with the leading Zeros.
the number element are store numbers and it ranges from 1 - 168
ideally if possible can you advise how do i change the code so it saves the output files like the below example if a store number is 2 digits and the 3 digits etc.
0001
0010
0120
Sub GenerateOutput()
Dim i As Long
Dim iGradeRow As Long
Dim iGradeCol As Long
Dim iPosSeqRow As Long
Dim s(1 To 7) As String
Dim aGradeData() As Variant
Dim aPosSeq() As Variant
Dim aOutput(1 To 500000, 1 To 12) As Variant
Dim iNextOutputRow As Long
Dim ExportWorkbook As Workbook
Dim Site As String
Dim Department As String
Dim Category As String
Dim ArticleGrade As String
Dim dp As String
Dim ct As String
Dim posQty As Long
Dim y As Long
Dim lrStores As Long
Dim recordId As Long
Dim selId As Long
'------------------------
Application.ScreenUpdating = False
' Get arrays of data to loop round
With ws_Grades
aGradeData = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column).Value2
End With
With ws_PosSeq
aPosSeq = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 20).Value2
End With
s(1) = "( "
's(2) = iGradeRow - 3
s(3) = " / "
's(4) = UBound(aGradeData, 1) - 3
s(5) = " ) "
's(6) = "Collecting data for: "
's(7) = aGradeData(iGradeRow, 2)
'Application.StatusBar = Join(s)
'DoEvents: DoEvents
'check the departments and categories
For iGradeRow = 4 To UBound(aGradeData, 1)
's(1) = "( "
s(2) = iGradeRow - 3
's(3) = " / "
s(4) = UBound(aGradeData, 1) - 3
's(5) = " ) "
s(6) = "Collecting data for: "
s(7) = aGradeData(iGradeRow, 2)
Application.StatusBar = Join(s)
DoEvents: DoEvents
Application.ScreenUpdating = False
Erase aOutput
iNextOutputRow = 1
For iGradeCol = 3 To UBound(aGradeData, 2)
Site = aGradeData(iGradeRow, 1)
Department = aGradeData(1, iGradeCol)
Category = aGradeData(3, iGradeCol)
ArticleGrade = aGradeData(iGradeRow, iGradeCol)
If iNextOutputRow = 1 Then
recordId = 1
selId = 1
Else
recordId = aOutput(iNextOutputRow - 1, 1) + 1
selId = aOutput(iNextOutputRow - 1, 2) + 1
End If
'check the departments & categories in the opened workbook
For iPosSeqRow = 3 To UBound(aPosSeq, 1)
'if there is nil in the first column, go to the next loop
If aPosSeq(iPosSeqRow, 1) = 0 Then GoTo NextDepartment
'if the department name and category name matches:
If (Trim(LCase(aPosSeq(iPosSeqRow, 2))) = Trim(LCase(Department))) And (Trim(LCase(aPosSeq(iPosSeqRow, 3))) = Trim(LCase(Category))) Then
dp = aPosSeq(iPosSeqRow, 2)
ct = aPosSeq(iPosSeqRow, 3)
'check wether the grades match:
If Not Trim(LCase(aPosSeq(iPosSeqRow, 6))) = Trim(LCase(ArticleGrade)) Then GoTo NextValue
'check pos qty:
posQty = aPosSeq(iPosSeqRow, 12)
'check department: same like the last one?:
If Not iNextOutputRow = 1 Then
If Trim(LCase(aOutput(iNextOutputRow - 2, 7))) = Trim(LCase(Site)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 5))) = Trim(LCase(dp)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 6))) = Trim(LCase(ct)) Then GoTo Level3
If Trim(LCase(aOutput(iNextOutputRow - 2, 7))) = Trim(LCase(Site)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 5))) = Trim(LCase(dp)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 6))) <> Trim(LCase(ct)) Then GoTo Level2
If Trim(LCase(aOutput(iNextOutputRow - 2, 7))) = Trim(LCase(Site)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 5))) <> Trim(LCase(dp)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 6))) <> Trim(LCase(ct)) Then GoTo Level2
End If
Level1:
' Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
' SEL_ID
aOutput(iNextOutputRow, 2) = selId
' Front + Back
aOutput(iNextOutputRow, 3) = "F"
' Template_Type
aOutput(iNextOutputRow, 4) = "Store"
' Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
' Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
' SEL_ID
aOutput(iNextOutputRow, 2) = selId
' Back
aOutput(iNextOutputRow, 3) = "B"
' Template_Type
aOutput(iNextOutputRow, 4) = "Store"
' Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
Level2:
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2) + 1
'Front_Back
aOutput(iNextOutputRow, 3) = "F"
'Template_Type
aOutput(iNextOutputRow, 4) = "Category"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2)
'Front_Back
aOutput(iNextOutputRow, 3) = "B"
'Template_Type
aOutput(iNextOutputRow, 4) = "Category"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
Level3:
For i = 1 To posQty
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
If i = 1 Then
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2) + 1
Else
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2)
End If
'Front_Back
aOutput(iNextOutputRow, 3) = "F"
'Template_Type
aOutput(iNextOutputRow, 4) = "SEL"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
'Barcode No
aOutput(iNextOutputRow, 8) = aPosSeq(iPosSeqRow, 8)
'Article Description
aOutput(iNextOutputRow, 9) = aPosSeq(iPosSeqRow, 7)
'WasWas
aOutput(iNextOutputRow, 10) = aPosSeq(iPosSeqRow, 13)
'Was
aOutput(iNextOutputRow, 11) = aPosSeq(iPosSeqRow, 14)
'Now
aOutput(iNextOutputRow, 12) = aPosSeq(iPosSeqRow, 16)
iNextOutputRow = iNextOutputRow + 1
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2)
'Front_Back
aOutput(iNextOutputRow, 3) = "B"
'Template_Type
aOutput(iNextOutputRow, 4) = "SEL"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
'Barcode No
aOutput(iNextOutputRow, 8) = aPosSeq(iPosSeqRow, 8)
'Article Description
aOutput(iNextOutputRow, 9) = aPosSeq(iPosSeqRow, 7)
iNextOutputRow = iNextOutputRow + 1
Next i
End If
NextValue:
Next iPosSeqRow
NextDepartment:
Next iGradeCol
's(1) = "( "
's(2) = iGradeRow - 3
's(3) = " / "
's(4) = UBound(aGradeData, 1) - 3
's(5) = " ) "
s(6) = "Generating export for: "
's(7) = aGradeData(iGradeRow, 2)
Application.StatusBar = Join(s)
DoEvents: DoEvents
Application.ScreenUpdating = False
' Clean output data
For i = 1 To iNextOutputRow
aOutput(i, 1) = Format(aOutput(i, 1), "0000000")
aOutput(i, 2) = Format(aOutput(i, 2), "0000000")
aOutput(i, 7) = Format(aOutput(i, 7), "0000")
aOutput(i, 8) = "'" & aOutput(i, 8)
Next i
ws_Output.Cells(2, 1).Resize(ws_Output.UsedRange.Rows.Count, 12).ClearContents
ws_Output.Cells(2, 1).Resize(iNextOutputRow, 12).Value2 = aOutput
Application.ScreenUpdating = False
If ExportWorkbook Is Nothing Then
Set ExportWorkbook = Workbooks.Add
ThisWorkbook.Activate
End If
Application.ScreenUpdating = False
ExportWorkbook.Worksheets(1).Cells.Clear
ws_Output.UsedRange.Copy
ExportWorkbook.Worksheets(1).Cells(1, 1).PasteSpecial xlPasteAll
Application.CutCopyMode = False
ExportWorkbook.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & aGradeData(iGradeRow, 1) & "_" & aGradeData(iGradeRow, 2) & "_" & Format(Now(), "ddmmyyyy_hhmm") & ".xlsx"
ws_Output.Cells(2, 1).Resize(ws_Output.UsedRange.Rows.Count, 12).ClearContents
Next iGradeRow
EndingSub:
ExportWorkbook.Close False
Set ExportWorkbook = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Generated Workbooks.", vbInformation
End Sub
Appent 3 zeros to the left of the number element and use
Right() to get exact 4 digits
You should not post your entire code, but rather the relevant parts of it only, so that noone needs to search through the code, to find the importand parts.
To your question:
To fill your numbers with leading zeros you could do something like the following:
Sub test()
Dim numLen As Integer
Dim i As Integer
Dim test As String
numLen = 4 '4 is the lengh like in your example `0001`
'test = "1"
'test = "11" 'Some numbers to test the code
test = "111"
'Depending on the Lenght of the String, additional leading zeros will be added
For i = Len(test) To numLen - 1
test = "0" & test
Next
MsgBox (test)
End Sub
lastColumn_Of_PO_line_Big_Table = Sheets("PO_line_Big_Table").UsedRange.Columns.Count + 1
a = Dict_Metadata.Keys
For Each b In a
For i = 1 To UBound(Arr_PO_line_Big_Table)
If Arr_PO_line_Big_Table(i, 1) = b Then
With Worksheets("PO_line_Big_Table")
nextRow = Sheets("Final_Result").Cells(Sheets("Final_Result").Rows.Count, 1).End(xlUp).row + 1
'.Cells(nextRow, "A") = strKey
'.Cells(i + 1, lastColumn_Of_PO_line_Big_Table) = "YES"
Union(.Cells(i + 1, "E"), .Cells(i + 1, "K"), .Cells(i + 1, "L"), .Cells(i + 1, "M")).Copy
Sheets("Final_Result").Range("B" & nextRow).PasteSpecial
End With
End If
Next
Next
Could someone please tell me why it doesn't paste the value in sheet "PO_line_Big_Table" to sheet Final_Result, thank you in advanced!!
I have a vba code that find the value at the intersection of columns and rows.
It works well with all my data except for one : it returns NA.
The value i want to return is the same as usual, it just doesn't work with this intersection.
Can you help me figure out why?
Thank you
With Perftitres
Set VMt = Data1.Range("U:U")
Set Ticker = Data1.Range("H:H")
End With
' Calculs de perf
For Each sht In Perftitres.Worksheets
If sht.Visible = True Then
If sht.Cells(1, 1) = "" Then
sht.Cells(1, 1) = "Date"
sht.Cells(1, 2) = "Code du placement"
sht.Cells(1, 3) = "Valeur marchande t"
sht.Cells(1, 4) = "Valeur marchande t-1"
sht.Cells(1, 5) = "Valeur des achats"
sht.Cells(1, 6) = "Valeur des ventes"
sht.Cells(1, 7) = "Facteur"
sht.Cells(1, 8) = "Rendement 1 mois"
End If
LastRowsht = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
LastColumnsht = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
sht.Cells(LastRowsht + 1, 1) = 20 & Left(Dateupdate, 2) & "-" & Right(Dateupdate, 2)
sht.Cells(LastRowsht + 1, 2) = sht.Name
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker))
End If
Next sht
Data1.Visible = True
Data2.Visible = True
This line doesn't work as expected for only one sheet. For every other one it works.
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker))
I just found the answer :
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker,0),0)
I had to had 0 and 0 for exact matches
I need to copy a lot of rows. I tried to do something.copy something else.paste but it's extremely slow
I tried to do
Range(..).value(formula) = Range(..).value(formula) but its not so good because i have a date there that turn to ######
I need a faster way to do this copy/paste
This is my code:
Function Last_Col(k As Long) As Long
Last_Col = Cells(k, Columns.Count).End(xlToLeft).Column
End Function
Function Last_Col_Doc() As Long
Last_Col_Doc = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Column
End Function
Function Is_Grouped(i As Long) As Boolean
Is_Grouped = (Cells(i, 2).Rows.OutlineLevel > 1)
End Function
Function Is_Bold(i As Long) As Boolean
Is_Bold = Cells(i, 2).Font.Bold
End Function
Function Print_NA(i As Long, k As Long) As Boolean
Range(Cells(i, 21), Cells(i, 21 + k - 2)).Value = "NA"
End Function
Function Last_Row() As Long
Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
End Function
Sub EditParanoia()
Dim FrstBlkRow As Long
Dim flag As Boolean
Dim i As Long
Dim HeadLen As Long
FrstBlkRow = Last_Col(1) + 1
If FrstBlkRow < 25 Then 'first edit
flag = True
i = 2
Do While flag
If Is_Bold(i) Then
flag = False
Else
i = i + 1
End If
Loop
HeadLen = Last_Col(i)
Range(Cells(i, 2), Cells(i, HeadLen)).Copy
Range(Cells(1, FrstBlkRow), Cells(1, FrstBlkRow + HeadLen - 2)).PasteSpecial
Else
FrstBlkRow = 21
HeadLen = 10
End If
Dim j As Long
For i = 2 To Last_Row Step 1
If Not Is_Grouped(i) And Not Is_Grouped(i + 1) And Cells(i, FrstBlkRow + 1).Value = vbNullString Then
'if not part of group
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 2)).Value = "NA"
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) And Is_Grouped(i + 2) And Not Is_Grouped(i + 3) Then
'if Part of group of 1 val
Range(Cells(i + 2, 2), Cells(i + 2, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 3)).PasteSpecial
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) Then
'if part of group of more then one val
j = 1
Do Until Is_Grouped(i + j) And Not Is_Grouped(i + j + 1)
'j will get the langth of any group
j = j + 1
Loop
'past the relevant cell in the right place
Range(Cells(i + 2, 2), Cells(i + 2 + j - 1 - 1, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i + j - 1 - 1, FrstBlkRow + HeadLen - 3)).PasteSpecial
'past the head respectively
Range(Cells(i, 1), Cells(i, 20)).Copy
Range(Cells(i + 1, 1), Cells(i + j - 2, FrstBlkRow - 1)).PasteSpecial
End If
Next
End Sub
When you say you've tried "Range(..).value(formula) = Range(..).value(formula)", what do you mean? You should be able to set two ranges equal to eachother:
Say A1:A10 has "Batman, 10-01-2015" and you want to copy that range to B1:B10, Range("B1:B10").Value = Range("A1:A10").Value. You can't do that? I tried it with dates, and it set the B range values to dates, no reformatting necessary.
I also notice in your code, you PasteSpecial, but don't specify what type of special paste. See the Microsoft (or this one) page for more info.
I need to reduce the code where am I writing the synatx manytimes for copying and pasting the row values.
Private Sub btn_upload_Click()
'Frm_Mainform.Show
'MsgBox ("Process Complete - Please Check File in Output Folder")
Const FOLDER As String = "C:\SBI_Files\"
On Error GoTo ErrorHandler
Dim i As Integer
i = 18
Dim fileName As String
fileName = Dir(FOLDER, vbDirectory)
Do While Len(fileName) > 0
If Right$(fileName, 4) = "xlsx" Or Right$(fileName, 3) = "xls" Then
i = i + 1
Dim currentWkbk As Excel.Workbook
Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName)
Cells(i, 1) = fileName
Cells(i + 1, 2) = "Equity"
Cells(i + 2, 2) = "Forex NOOP"
Cells(i + 3, 2) = "Fixed Income Securities ( including CP, CD, G Sec)"
Cells(i + 4, 2) = "Total"
Cells(i, 2) = "Details"
Cells(i, 3) = "Limit"
Cells(i, 4) = "Min Var"
Cells(i, 5) = "Max Var"
Cells(i, 6) = "No. of Breaches"
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G8:G8").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H8:H8").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I8:I8").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J8:J8").Value
i = i + 1
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G9:G9").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H9:H9").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I9:I9").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J9:J9").Value
i = i + 1
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G10:G10").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H10:H10").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I10:I10").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J10:J10").Value
i = i + 1
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G11:G11").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H11:H11").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I11:I11").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J11:J11").Value
i = i + 1
currentWkbk.Close
End If
fileName = Dir
Loop
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
You can replace all your Cells lines with these 4
update: added line for coping formats
'other code
Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName)
Cells(i, 1) = fileName
Cells(i + 1, 2).Resize(4, 1) = Application.Transpose(Array("Equity", "Forex NOOP", "Fixed Income Securities ( including CP, CD, G Sec)", "Total"))
Cells(i, 2).Resize(1, 5) = Array("Details", "Limit", "Min Var", "Max Var", "No. of Breaches")
Cells(i + 1, 3).Resize(4, 4) = currentWkbk.Sheets("VaR").Range("G8:J11").Value
currentWkbk.Sheets("VaR").Range("G8:J11").Copy Cells(i + 1, 3)
currentWkbk.Close