Public Sub AlignDate()
Dim X() As Variant
Dim shtArr() As Integer
Dim smallest_date As Date
Dim largest_date As Date
Dim FwdFill As Boolean
Dim BusDays As Boolean
Dim inputDate As Boolean
Sheets(3).Activate
Cells.ClearContents
ActiveWindow.FreezePanes = False
On Error Resume Next
Start:
If Sheet1.FileTypecsv.Value Then
FileType = Sheet1.FileTypecsv.Caption
mulSel = True
X = Application.GetOpenFilename(filefilter:="CSV Files,*.csv", _
MultiSelect:=True, Title:="File(s) to be aligned")
'Tests the variable X to see if it is valid
If UBound(X) = 0 Then Exit Sub
ReDim shtArr(1)
shtArr(1) = 1
If (MsgBox("Would you like to input min and max dates for alignment?", vbYesNo) = vbYes) Then
inputDate = False
Dim temp_smallest_date As Date
Dim temp_largest_date As Date
temp_smallest_date = minDateCSV(X())
temp_largest_date = maxDateCSV(X())
smallest_date = Application.InputBox("Enter min date(mm/dd/yyyy)", "Date Entry", , 250, 75, "", , 2)
If smallest_date = False Then Exit Sub
largest_date = Application.InputBox("Enter max date(mm/dd/yyyy)", "Date Entry", , 250, 75, "", , 2)
If largest_date = False Then Exit Sub
If temp_smallest_date < smallest_date Then smallest_date = temp_smallest_date
If temp_largest_date > largest_date Then largest_date = temp_largest_date
Else
Application.ScreenUpdating = False
inputDate = True
smallest_date = minDateCSV(X())
largest_date = maxDateCSV(X())
End If
ElseIf Sheet1.FileTypexls.Value Then
MsgBox "Still working on Excel file handling. Please use this tool for csv only."
Exit Sub
FileType = Sheet1.FileTypexls.Caption
mulSel = False
Target = Application.GetOpenFilename(filefilter:=FileType & " Files,*." & FileType, _
MultiSelect:=mulSel, Title:="File to be aligned")
If Target = False Then Exit Sub
ReDim X(1) As Variant
X(1) = Target
smallest_date = minDateXL(X(), shtArr())
largest_date = maxDateXL(X(), shtArr())
Else
MsgBox Prompt:="Select a File Type First", Buttons:=vbCritical
Exit Sub
End If
Dim fileName As String
fileName = ThisWorkbook.Name
currfileName = ThisWorkbook.Name
Application.ScreenUpdating = False
For Y = 1 To UBound(X)
Workbooks.Open X(Y)
currfileName1 = ActiveWorkbook.Name
Workbooks(currfileName1).Sheets(1).Copy After:=Workbooks(currfileName).Sheets(2 + Y)
Windows(currfileName1).Close
Next
X(1) = ActiveWorkbook.FullName
Windows(currfileName).Activate
Sheets(3).Activate
Cells("A3").Select
Dim range_len As Integer
Range("A1").Value = "Asset:"
Range("A2").Value = "date"
range_len = DateDiff("d", smallest_date, largest_date)
Range("A3").Value = smallest_date
Range("A3").Select
Selection.AutoFill Destination:=Range("A3:A" & range_len + 3), Type:=xlFillDefault
last_column = 2
Sheets(3).Activate
Dim datelocal As String
datelocal = Cells(row, 1).Value
For files2handle = 4 To ActiveWorkbook.Sheets.Count
Sheets(files2handle).Activate
Cells.End(xlEnd).Select
next_last_column = ActiveCell.Column
Range(Cells(1, ActiveCell.Column), Cells(2, 2)).Select
Selection.Copy
Sheets(3).Activate
Cells(1, last_column).Activate
ActiveCell.PasteSpecial (xlPasteAll)
Cells(3, last_column).Select
last_column = last_column + next_last_column - 1
Next
Sheets(3).Activate
Dim mat_row As Integer
For row = 3 To range_len + 3
Sheets(3).Activate
next_last_column = 1
last_column = 2
Dim test_val As Date
test_val = Cells(row, 1).Value
On Error Resume Next
For files2handle = 4 To ActiveWorkbook.Sheets.Count
last_column = last_column + next_last_column - 1
Sheets(files2handle).Activate
Cells.End(xlEnd).Select
next_last_column = ActiveCell.Column
Range("A1").Select
Cells.Find(What:=test_val, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
If ActiveCell.row <> 1 Then
mat_row = ActiveCell.row
Cells(mat_row, 1).Activate
Range(Cells(mat_row, 2), Cells(mat_row, next_last_column)).Copy
Sheets(3).Activate
Cells(row, last_column).Activate
ActiveCell.PasteSpecial xlPasteAll
End If
done:
Next
Next
Sheets(3).Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="", Replacement:="NA", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("B3").Select
Sheets(4).Select
For i = 4 To ActiveWorkbook.Sheets.Count
Sheets(i).Select False
Next
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets(2).Select
Application.ScreenUpdating = False
If Sheet1.FwdFillYes.Value Then
FwdFill = True
ElseIf Sheet1.FwdFillNo.Value Then
FwdFill = False
Else
MsgBox Prompt:="Select Whether to forward fill or not", Buttons:=vbCritical
Exit Sub
End If
If Sheet1.BusDaysYes.Value Then
BusDays = True
ElseIf Sheet1.BusDaysNo.Value Then
BusDays = False
Else
MsgBox Prompt:="Select Whether to have only business days or not", Buttons:=vbCritical
Exit Sub
End If
Sheets(3).Select
Range("B1").Select
Dim lastRow As Integer
lastRow = Selection.End(xlDown).row
Range("A1").Select
Dim lastCol As Integer
lastCol = Selection.End(xlToRight).Column
If FwdFill Then
Dim previousRow As Integer
Dim previousCol As Integer
previousRow = 0
'Cells.Find(What:="NA", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
'While (ActiveCell.row <= lastRow And (ActiveCell.row > previousRow) Or _
(ActiveCell.row = previousRow And ActiveCell.Column > previousCol))
For row = 1 To lastRow
For col = 2 To lastCol
Cells(row, col).Select
If (ActiveCell.Value = "NA") Then
previousRow = ActiveCell.row
previousCol = ActiveCell.Column
If (IsNumeric(ActiveCell.Offset(-1, 0).Value)) Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
End If
End If
'Cells.Find(What:="NA", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Next
Next
End If
'den:
Range("A1").Select
'On Error Resume Next
If BusDays Then
Range("A1").Select
'Dim i As Integer
For i = 1 To lastRow
If (IsDate(Cells(i, 1).Value)) Then
If (DatePart("w", Cells(i, 1).Value) = 1 Or DatePart("w", Cells(i, 1).Value) = 7) Then
Rows(i & ":" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
End If
Next
End If
Application.ScreenUpdating = True
Sheets(3).Select
Range("B3").Select
Cells.EntireColumn.AutoFit
Range("B3").Select
ActiveWindow.FreezePanes = True
Exit Sub
Application.ScreenUpdating = True
If (DateDiff("d", smallest_date, largest_date) <= 0) Then
MsgBox Prompt:="Issue with data. Max date can not be less than or Equal to Min date. Check!!", Buttons:=vbCritical
Exit Sub
End If
If MsgBox("Date Range:- " & smallest_date & " To " & largest_date, vbOKCancel) = vbCancel Then
Exit Sub
End If
Call alignFiles(X(), smallest_date, largest_date, FwdFill, BusDays, fileName)
Windows(fileName).Activate
If Sheet1.CollDataYes.Value Then
If Sheet1.BusDaysYes.Value = True Then
If inputDate = True Then
For Z = 4 To ActiveWorkbook.Sheets.Count
If Z = 4 Then
Sheets(Z).Activate
Cells.Copy
Sheets(3).Activate
Range("A1").PasteSpecial (xlPasteAll)
Else
Sheets(Z).Activate
Range("B1").Select
Application.CutCopyMode = False
Range("IV1").Select
Selection.End(xlToLeft).Select
Range(Selection, "B1").Select
Range(Selection, Selection.End(xlDown)).Copy
Sheets(3).Activate
Range("A1").Select
Selection.End(xlToRight).Offset(0, 1).Select
ActiveSheet.Paste
End If
Next
Sheets(3).Activate
If IsDate(ActiveSheet.Range("A2").Value) Then
Range("B2").Select
Else
Range("B3").Select
End If
Cells.EntireColumn.AutoFit
ActiveWindow.FreezePanes = True
Else
MsgBox "Data Can not be Collated if date range has been given as input by user"
End If
Else
MsgBox "Data can be collated only if OnlyBusinessDays is True"
End If
Else
Sheets("Run").Range("A4").Select
End If
Application.DisplayAlerts = False
For Z = 4 To ActiveWorkbook.Sheets.Count
Sheets(4).Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'If Sheet1.CollDataNo Or Not (inputDate) Then
Sheets("Run").Activate
'End If
End Sub
Private Function minDateCSV(X() As Variant) As Date
Dim smallDates As Date
Dim smallDate As Date
For Y = 1 To UBound(X)
Workbooks.Open X(Y)
Sheets(1).Activate
' Assumption: The Csv file has atleast one line of header and the date is in the 1st column itself. Phew!wat a relief
If IsDate(ActiveSheet.Range("A2").Value) Then
smallDates = ActiveSheet.Range("A2").Value
Else
'If the date is not in the A2 then it is definitely in A3.
smallDates = ActiveSheet.Range("A3").Value
End If
If Y > 1 Then
If (DateDiff("d", smallDates, smallDate) > 0) Then
smallDate = smallDates
End If
Else
smallDate = smallDates
End If
ActiveWorkbook.Close
Next
minDateCSV = smallDate
End Function
Private Function maxDateCSV(X() As Variant) As Date
Dim largeDates As Date
Dim largeDate As Date
Dim sheet_index As Integer
For Y = 1 To UBound(X)
Workbooks.Open X(Y)
Sheets(1).Activate
' Assumption: The Csv file has more than two lines of input and the date is in column A
' and the data is continuous
largeDates = ActiveSheet.Range("A1").End(xlDown).Value
If Y > 1 Then
If (DateDiff("d", largeDates, largeDate) < 0) Then
largeDate = largeDates
End If
Else
largeDate = largeDates
End If
ActiveWorkbook.Close
Next
maxDateCSV = largeDate
End Function
Private Sub alignFiles(X() As Variant, smallest_date As Date, largest_date As Date, FwdFill As Boolean, BusDays As Boolean, fileName As String)
smallest_value = smallest_date
largest_value = largest_date
sheet_index = 1
tdate = smallest_value
'Populating NA and aligning the data
For Y = 1 To UBound(X)
'Workbooks.Open X(Y)
'fileName1 = ActiveWorkbook.Name
For sheet_index = 1 To ActiveWorkbook.Sheets.Count
row = Row_Col(sheet_index)
col = 1
tdate = smallest_value
If row = 0 Then
GoTo x2
End If
Do Until tdate > largest_value
If row = 65537 Then
GoTo x2:
End If
If Sheets(sheet_index).Cells(row, col).Value <= tdate And Sheets(sheet_index).Cells(row, col).Value <> "" Then
GoTo X:
'Ignoring Saturdays and Sundays
Else 'If (DatePart("w", tdate) <> 1 And DatePart("w", tdate) <> 7) Then
Sheets(sheet_index).Cells(row, col).EntireRow.Insert
Sheets(sheet_index).Cells(row, col) = tdate
Sheets(sheet_index).Activate
Sheets(sheet_index).Range(Cells(row, 2), Cells(row, _
Cells(row - 1, 1).End(xlToRight).Column)).Value = "NA"
End If
X:
If (tdate = Sheets(sheet_index).Cells(row, col).Value) Or DatePart("w", tdate) = 1 Or DatePart("w", tdate) = 7 Then
tdate = DateAdd("d", 1, tdate)
End If
If DatePart("w", tdate) <> 1 And DatePart("w", tdate) <> 7 Then
row = row + 1
End If
Loop
x2:
Next
'On Error GoTo den
Range("B1").Select
Dim lastRow As Integer
lastRow = Selection.End(xlDown).row
Range("A1").Select
Dim lastCol As Integer
lastCol = Selection.End(xlToRight).Column
If FwdFill Then
Dim previousRow As Integer
Dim previousCol As Integer
previousRow = 0
'Cells.Find(What:="NA", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
'While (ActiveCell.row <= lastRow And (ActiveCell.row > previousRow) Or _
(ActiveCell.row = previousRow And ActiveCell.Column > previousCol))
For row = 1 To lastRow
For col = 2 To lastCol
Cells(row, col).Select
If (ActiveCell.Value = "NA") Then
previousRow = ActiveCell.row
previousCol = ActiveCell.Column
If (IsNumeric(ActiveCell.Offset(-1, 0).Value)) Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
End If
End If
'Cells.Find(What:="NA", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Next
Next
End If
'den:
Range("A1").Select
'On Error Resume Next
If BusDays Then
Range("A1").Select
Dim i As Integer
For i = 1 To lastRow
If (IsDate(Cells(i, 1).Value)) Then
If (DatePart("w", Cells(i, 1).Value) = 1 Or DatePart("w", Cells(i, 1).Value) = 7) Then
Rows(i & ":" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
End If
Next
Workbooks(fileName1).Sheets(1).Copy After:=Workbooks(fileName).Sheets(2 + Y)
Windows(fileName1).Activate
Range("A1").Select
End If
Next
End Sub
Private Function Row_Col(i) As Integer
Dim row, col As Integer
row = 1
col = 1
Do Until Sheets(i).Cells(row, col).Value = ""
If IsDate(Sheets(i).Cells(row, col).Value) Then
Row_Col = row
Exit Function
Else
row = row + 1
End If
Loop
End Function
Private Function minDateXL(X() As Variant, shtArr() As Integer) As Date
Dim smallDates As Date
Dim smallDate As Date
For Y = 1 To UBound(X)
Workbooks.Open X(Y)
For sheet_index = 1 To ActiveWorkbook.Sheets.Count
Sheets(sheet_index).Activate
If (MsgBox("Do you want to include the tab " & ActiveSheet.Name & " in alignment process?", vbYesNo) = vbNo) Then
GoTo hmmm
End If
' Assumption: The Csv file has atleast one line of header and the date is in the 1st column itself. Phew!wat a relief
If IsDate(ActiveSheet.Range("A2").Value) Then
smallDates = ActiveSheet.Range("A2").Value
Else
'If the date is not in the A2 then it is definitely in A3.
smallDates = ActiveSheet.Range("A3").Value
End If
If Y > 1 Then
If (DateDiff("d", smallDates, smallDate) > 0) Then
smallDate = smallDates
End If
Else
smallDate = smallDates
End If
hmmm:
Next
ActiveWorkbook.Close
Next
minDateXL = smallDate
End Function
Private Function maxDateXL(X() As Variant, shtArr() As Integer) As Date
Dim largeDates As Date
Dim largeDate As Date
For Y = 1 To UBound(X)
Workbooks.Open X(Y)
For sheet_index = 1 To ActiveWorkbook.Sheets.Count
Sheets(sheet_index).Activate
If (MsgBox("Do you want to include the tab " & ActiveSheet.Name & " in alignment process?", vbYesNo) = vbNo) Then
GoTo hmmm
End If
' Assumption: The Csv file has more than two lines of input and the date is in column A
' and the data is continuous
largeDates = ActiveSheet.Range("A1").End(xlDown).Value
If Y > 1 Then
If (DateDiff("d", largeDates, largeDate) < 0) Then
largeDate = largeDates
End If
Else
largeDate = largeDates
End If
hmmm:
Next
ActiveWorkbook.Close
Next
maxDateXL = largeDate
End Function
Friday, September 12, 2008
Subscribe to:
Posts (Atom)