Wednesday, March 26, 2008

Reading and writing in a TextFile from VBA

Sub LogInformation(LogMessage As String)
Const LogFileName As String = "C:\FOLDERNAME\TEXTFILE.LOG"
Dim txtString as String
Dim FileNum As Integer
FileNum = FreeFile ' next file number
Open LogFileName For Append As #FileNum ' creates the file if it doesn't exist
Print #FileNum, LogMessage ' write information at the end of the text file
Close #FileNum ' close the file
'For reading the file :
While not EOF(FileNum)
Line Input #FileNum, txtString ' txtString contains the line read by the command
End Sub

Tuesday, March 25, 2008

Import data from a text file (ADO)

The procedure below can be used to get an ADO recordset from a text file and fill in the result in a worksheet.

Sub GetTextFileData(strSQL As String, strFolder As String, rngTargetCell As Range)
' example: GetTextFileData "SELECT * FROM filename.txt", _
"C:\FolderName", Range("A3")
' example: GetTextFileData "SELECT * FROM filename.txt WHERE fieldname = 'criteria'", _
"C:\FolderName", Range("A3")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, f As Integer
If rngTargetCell Is Nothing Then Exit Sub
Set cn = New ADODB.Connection
On Error Resume Next
cn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
"Dbq=" & strFolder & ";" & _
On Error GoTo 0
If cn.State <> adStateOpen Then Exit Sub
Set rs = New ADODB.Recordset
On Error Resume Next
rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
On Error GoTo 0
If rs.State <> adStateOpen Then
Set cn = Nothing
Exit Sub
End If
' the field headings
For f = 0 To rs.Fields.Count - 1
rngTargetCell.Offset(0, f).Formula = rs.Fields(f).Name
Next f
rngTargetCell.Offset(1, 0).CopyFromRecordset rs ' works in Excel 2000 or later
'RS2WS rs, rngTargetCell ' works in Excel 97 or earlier
Set rs = Nothing
Set cn = Nothing
End Sub

The procedure can be used like this:

Sub TestGetTextFileData()
Application.ScreenUpdating = False
GetTextFileData "SELECT * FROM filename.txt", "C:\FolderName", Range("A3")
' GetTextFileData "SELECT * FROM filename.txt WHERE fieldname = 'criteria'", _
"C:\FolderName", Range("A3")
ActiveWorkbook.Saved = True
End Sub

Monday, March 24, 2008

Code to View Pivot Data within a date range

The following code works on the pivot with the following format :

Items Date1Date2Date3Date4
Item 1 DataDataDataData
Item 2 DataDataDataData
Item 3 DataDataDataData
Item 4DataDataDataData

Suppose, if you have a combobox with the date range, and you want to show those date columns which fall in the given range, following is the code which you can use. The example takes a week input from the user, where, in the AN Column, the Combobox option is given and in the AO column, the actual date value is given. For example, in AN1 the value is given as February-17 to February-23, and in AO1, the value of Feb 17 is given as 39495.

Public Sub CMBMacro()
Dim prevIndx As Integer
Dim cmbValue As Long
Dim upRange As Long
Dim pivot As PivotTable
Dim pvtItm As PivotItem
Dim ifNum As Long
Dim iCounter As Integer
Dim strngArr() As String
Dim strngCn As String
Dim prvDate As Long
Dim position As Integer
Dim prevItm() As PivotItem
Dim indxChckd As Integer
Dim extDate As Integer
Dim bool As Boolean
indxChckd = Me.Range("k1").Value
cmbValue = Me.Range("AO" & indxChckd).Value - 1 ' It will take the Date selected in the combo.
upRange = cmbValue + 7 'It will add up 7 days to get the upper range of the week.
iCounter = 0
If Not Application.EnableEvents Then
Exit Sub
End If
position = 2
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set pivot = Me.PivotTables(pvtName)
bool = False
For Each pvtItm In pivot.PivotFields("Date").PivotItems
If IsDate(pvtItm.Value) And pvtItm.RecordCount > 0 Then
ifNum = CDate(pvtItm.Value)
If ifNum > cmbValue And ifNum < upRange Then
If pvtItm.Visible = False Then pvtItm.Visible = True
bool = True
iCounter = iCounter + 1
End If
End If
ReDim prevItm(iCounter)
iCounter = 1

For Each pvtItm In pivot.PivotFields("Date").PivotItems
If IsDate(pvtItm.Value) And pvtItm.RecordCount > 0 Then
ifNum = CDate(pvtItm.Value)
If (ifNum <= cmbValue Or ifNum >= upRange) And pvtItm.Visible = True And bool Then
pvtItm.Visible = False
End If

If pvtItm.Visible = True Then
Set prevItm(iCounter) = pvtItm
iCounter = iCounter + 1
End If
End If

************************************************The Following Code sorts the date columns. It is required if the date columns are not sorted by default********* *************************************
For position = 1 To UBound(prevItm)
prvDate = CDate(prevItm(position))
For iCounter = position + 1 To UBound(prevItm)
ifNum = CDate(prevItm(iCounter))
If prvDate > ifNum Then
prevItm(position).position = prevItm(iCounter).position
End If

If Not bool Then
MsgBox "No Items Found for this range.", vbCritical, "Error"
End If

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Hope this has helped you all.