RavishankerMaduriVBSCRIPT: 2010

Sub DelCellsUp()
'ravishanker
'Delete Empty Cells and cells with only spaces in range
' and move cells up from below even if not in range
'Will process single range of one or more columns
'Will not remove cells with formulas
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim rng As Range, ix As Long
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
If rng Is Nothing Then
MsgBox "nothing in Intersected range to be checked/

Sub AllFolderFiles()
Dim wb As Workbook
Dim TheFile As String
Dim MyPath As String
MyPath = "C:\Ravi\ExcelFiles"
ChDir MyPath
TheFile = Dir("*.xl*")
Do While TheFile <> ""
Set wb = Workbooks.Open(MyPath & "\" & TheFile)
MsgBox wb.FullName
i = 1
wb.Activate

Rem wb.Application.Range("C1:C13").Formula = "=A" & i & "*B" & i
Rem AL = AJ * AK
wb.Application.Range("AL1:AL500").Formula = "=AJ" & i & "*AK" & i

Rem = AV * AW
wb.Application.Range("AX1:AX500").Formula = "=AV" & i & "*AW" & i
Rem BJ = BH * BI
wb.Application.Range("BJ1:AX500").Formula = "=BH" & i & "*BI" & i
Rem BV = BT * BU
wb.Application.Range("BV1:AX500").Formula = "=BT" & i & "*BU" & i

DeleteExcelSheetColumns
Rem wb.Range("A1:A500").Formula = "=A" & i * "C" & i
Rem cell.SetAddInFormula("FileInLibraryDir.xla", "=FuncName(A1,A2:A7,...)")
wb.Save

wb.Close
i = i + 1
TheFile = Dir
Loop
End Sub
Sub DeleteGroupColumns(DeleteRange As Range)
' Deletes all empty columns in DeleteRange
' Example: DeleteEmptyColumns Selection
' Example: DeleteEmptyColumns Range("A1:Z1")
Dim cCount As Integer, c As Integer
If DeleteRange Is Nothing Then Exit Sub
If DeleteRange.Areas.Count > 1 Then Exit Sub
With DeleteRange
cCount = .Columns.Count
For c = cCount To 1 Step -1
If Application.CountA(.Columns(c)) = 0 Then
.Columns(c).EntireColumn.Delete
End If
Next c
End With
End Sub

Sub DeleteExcelSheetColumns()
Worksheets("Sheet1").Range("A1:A1").Formula = "=COUNTIF(A7:BV7,""Plan Revenue"")"
If (ActiveCell.Value <> 5) Then

ActiveCell.Value = ""

DeleteGroupColumns Range("F1:N1")
DeleteGroupColumns Range("AD1:AL1")
DeleteGroupColumns Range("AG1:AO1")
DeleteGroupColumns Range("AJ1:AR1")
Worksheets("Sheet1").Range("B1:B1").Formula = "=COUNTIF(A7:BV7,""Plan Revenue"")"
ActiveCell.Value = ""
ActiveWorkbook.Save
End If
Rem Caliculate

End Sub

Sub Caliculate()
Rem Q= r* S
Rem AL = AJ * AK

szStart = "17,8"
szEnd = "17,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 18) * ActiveSheet.Cells(nRow, 19)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
Rem AX = AV * AW --- w=u*V

szStart = "24,8"
szEnd = "24,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 22) * ActiveSheet.Cells(nRow, 23)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow

Rem BJ = BH * BI --- z=x*y
szStart = "26,8"
szEnd = "26,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 25) * ActiveSheet.Cells(nRow, 24)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
Rem BV = BT * BU AC=AA*AB

szStart = "29,8"
szEnd = "29,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 27) * ActiveSheet.Cells(nRow, 28)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
End Sub

On Error Resume Next
Dim fso, folder, files, NewsFile,sFolder

Set fso = CreateObject("Scripting.FileSystemObject")
sFolder = Wscript.Arguments.Item(0)
If sFolder = "" Then
Wscript.Echo "No Folder parameter was passed"
Wscript.Quit
End If
Set NewFile = fso.CreateTextFile(sFolder&"\FileList.txt", True)
Set folder = fso.GetFolder(sFolder)
Set files = folder.Files

For each folderIdx In files
NewFile.WriteLine(folderIdx.Name)
Next
NewFile.Close
Code:
Dim strMessageBody As String
Dim strAttachment As String
Dim dtStartDate As Date
Dim dtEndDate As Date
Dim globalRowCount As Long

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Option Explicit

Sub Export()

Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
Dim olDestFolder As Outlook.MAPIFolder
Dim strprompt As String
Dim recipient As String
Dim localRowCount As Integer

Set xlApp = CreateObject("Excel.Application")

'Initialize count of folders searched
globalRowCount = 1

' Get a reference to the Outlook application and session.
Set olApp = Application
Set olSession = olApp.GetNamespace("MAPI")

' Allow the user to input the start date
strprompt = "Enter the start date to search from:"
dtStartDate = InputBox(strprompt, "Start Date", Now() - 7)

' Allow the user to input the end date
strprompt = "Enter the end date to search to:"
dtEndDate = InputBox(strprompt, "End Date", Now())

' UserForm1.Show

If (IsNull(dtStartDate) <> 1) And (IsNull(dtEndDate) <> 1) Then

' Allow the user to pick the folder in which to start the search.
MsgBox ("Pick the source folder (Feedback)")
Set olStartFolder = olSession.PickFolder

' Check to make sure user didn't cancel PickFolder dialog.
If Not (olStartFolder Is Nothing) Then
' Start the search process.
ProcessFolder olStartFolder
MsgBox CStr(globalRowCount) & " messages were found."
End If

xlApp.Quit

' strprompt = "Enter the recipient of the .html attachment in xxx@xxx.xxx format: "
' recipient = InputBox(strprompt, "Recipient's email", "dba@xxxx.com")

' DTSMailer strMessageBody, strAttachment
' DTSMailer commented out b/c no DTS package reference available on Users machine.

' MsgBox "Email sent to " & recipient
MsgBox "Process is complete. Check K:\feedback\htm\ for available files."

End If
End Sub

Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)

Dim i As Long
Dim ValidEmails As Long
ValidEmails = 0

For i = CurrentFolder.Items.Count To 1 Step -1
If ((CurrentFolder.Items(i).ReceivedTime >= dtStartDate) And (CurrentFolder.Items(i).ReceivedTime < dtEndDate)) Then
ValidEmails = ValidEmails + 1
End If
Next

If CurrentFolder.Items.Count >= 1 And ValidEmails >= 1 Then

Dim localRowCount As Integer
Dim xlName As String

Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

localRowCount = 1
xlName = CStr(Format(dtStartDate, "MMDDYYYY")) & "_" & CurrentFolder.Name & "_feedback"

xlSheet.Cells(localRowCount, 1) = "SUBJECT"
xlSheet.Cells(localRowCount, 2) = "SENDER"
xlSheet.Cells(localRowCount, 3) = "RECEIVED DATE"
xlSheet.Cells(localRowCount, 4) = "MESSAGE BODY"

' Late bind this object variable,
' since it could be various item types
Dim olTempItem As Object
Dim olNewFolder As Outlook.MAPIFolder

' Loop through the items in the current folder.
' Looping through backwards in case items are to be deleted,
' as this is the proper way to delete items in a collection.
For i = CurrentFolder.Items.Count To 1 Step -1

Set olTempItem = CurrentFolder.Items(i)

' Check to see if a match is found
If ((olTempItem.ReceivedTime >= dtStartDate) And (olTempItem.ReceivedTime < dtEndDate)) Then
localRowCount = localRowCount + 1
globalRowCount = globalRowCount + 1
xlSheet.Cells(localRowCount, 1) = olTempItem.Subject
xlSheet.Cells(localRowCount, 2) = olTempItem.SenderEmailAddress
xlSheet.Cells(localRowCount, 3) = CStr(Format(olTempItem.ReceivedTime, "MM/DD/YYYY"))
' Added this row of Code 4/3/06 jmr
xlSheet.Cells(localRowCount, 4) = WorksheetFunction.Clean(olTempItem.Body)[/b]
' original code - commented out 4/3/06
' xlSheet.Cells(localRowCount, 4) = Replace(Replace(Replace(olTempItem.Body, Chr(9), " "), Chr(10) & Chr(10), Chr(10)), Chr(13), "")
End If

Next

readability_and_HTML_export
xlBook. SaveAs ("\\stm-fs1\marketing-shared\feedback\xls\" & xlName & ".xls")

ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceSheet, _
FileName:="\\stm-fs1\marketing-shared\feedback\htm\" & xlName & ".htm", _
Sheet:="Sheet1", _
Source:="", _
HtmlType:=xlHtmlStatic).Publish

' strAttachment = strAttachment & "\\stm-fs1\finapps\dynamics\feedback\" & xlName & ".htm; "

xlBook.Save
xlBook.Close

End If

' New temp code - 040406

' Loop through and search each subfolder of the current folder.
For Each olNewFolder In CurrentFolder.Folders

Select Case olNewFolder.Name

Case "Deleted Items", "Drafts", "Export", "Junk E - mail", "Notes"
Case "Outbox", "Sent Items", "Search Folders", "Calendar", "Inbox"
Case "Contacts", "Journal", "Shortcuts", "Tasks", "Folder Lists"
Case Else
ProcessFolder olNewFolder

End Select

Next olNewFolder

' The next five lines are the original code

' Loop through and search each subfolder of the current folder.
' For Each olNewFolder In CurrentFolder.Folders
' If olNewFolder.Name <> "Deleted Items" And olNewFolder.Name <> "Drafts" And olNewFolder.Name <> "Export" And olNewFolder.Name <> "Junk E - mail" And olNewFolder.Name <> "Outbox" And olNewFolder.Name <> "Sent Items" And olNewFolder.Name <> "Search Folders" And olNewFolder.Name <> "Calendar" And olNewFolder.Name <> "Contacts" And olNewFolder.Name <> "Notes" And olNewFolder.Name <> "Journal" And olNewFolder.Name <> "Shortcuts" And olNewFolder.Name <> "Tasks" And olNewFolder.Name <> "Folder Lists" And olNewFolder.Name <> "Inbox" Then
' ProcessFolder olNewFolder

' End If
' Next
End Sub

Private Sub readability_and_HTML_export()
'
' readability_and_HTML_export Macro

'
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Columns("A:A").ColumnWidth = 32
' Range("A1").Select
' Range(Selection, Selection.End(xlDown)).Select
' Range(Selection, Selection.End(xlToRight)).Select
Cells.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1:D1").Select
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
Selection.Font.Bold = True
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
If Columns("D:D").ColumnWidth < 80 Then
Columns("D:D").ColumnWidth = 80
End If

If Columns("B:B").ColumnWidth > 40 Then
Columns("B:B").ColumnWidth = 40
End If
End Sub

'Private Sub DTSMailer(messagebody As String, attachmentstring As String)
Private Sub DTSMailer()
Dim oPKG As New DTS.Package

oPKG.LoadFromSQLServer "SQLServer", , , _
DTSSQLStgFlag_UseTrustedConnection, , , , "Feedback_Mailer"
oPKG.FailOnError = True

' oPKG.GlobalVariables.Item("messagebody") = messagebody
' oPKG.GlobalVariables.Item("attachmentstring") = attachmentstring

oPKG.Execute
oPKG.UnInitialize
Set oPKG = Nothing
End Sub
Sub DeleteGroupColumns(DeleteRange As Range)
' Deletes all empty columns in DeleteRange
' Example: DeleteEmptyColumns Selection
' Example: DeleteEmptyColumns Range("A1:Z1")
Dim cCount As Integer, c As Integer
If DeleteRange Is Nothing Then Exit Sub
If DeleteRange.Areas.Count > 1 Then Exit Sub
With DeleteRange
cCount = .Columns.Count
For c = cCount To 1 Step -1
If Application.CountA(.Columns(c)) = 0 Then
.Columns(c).EntireColumn.Delete
End If
Next c
End With
End Sub

Private Sub Worksheet_Activate()

DeleteExcelSheetColumns

End Sub
Sub DeleteExcelSheetColumns()
Worksheets("Sheet1").Range("A1:A1").Formula = "=COUNTIF(A7:BV7,""Plan Revenue"")"
If (ActiveCell.Value <> 5) Then

ActiveCell.Value = ""

DeleteGroupColumns Range("F1:N1")
DeleteGroupColumns Range("AD1:AL1")
DeleteGroupColumns Range("AG1:AO1")
DeleteGroupColumns Range("AJ1:AR1")
Worksheets("Sheet1").Range("B1:B1").Formula = "=COUNTIF(A7:BV7,""Plan Revenue"")"
ActiveCell.Value = ""
ActiveWorkbook.Save
End If
Caliculate

End Sub

Sub Caliculate()
Rem Q= r* S
Rem AL = AJ * AK

szStart = "17,8"
szEnd = "17,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 18) * ActiveSheet.Cells(nRow, 19)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
Rem AX = AV * AW --- w=u*V

szStart = "24,8"
szEnd = "24,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 22) * ActiveSheet.Cells(nRow, 23)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow

Rem BJ = BH * BI --- z=x*y
szStart = "26,8"
szEnd = "26,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 25) * ActiveSheet.Cells(nRow, 24)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
Rem BV = BT * BU AC=AA*AB

szStart = "29,8"
szEnd = "29,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 27) * ActiveSheet.Cells(nRow, 28)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
End Sub

Sub DeleteGroupColumns(DeleteRange As Range)
' Deletes all empty columns in DeleteRange
' Example: DeleteEmptyColumns Selection
' Example: DeleteEmptyColumns Range("A1:Z1")
Dim cCount As Integer, c As Integer
If DeleteRange Is Nothing Then Exit Sub
If DeleteRange.Areas.Count > 1 Then Exit Sub
With DeleteRange
cCount = .Columns.Count
For c = cCount To 1 Step -1
If Application.CountA(.Columns(c)) = 0 Then
.Columns(c).EntireColumn.Delete
End If
Next c
End With
End Sub

Private Sub Worksheet_Activate()

DeleteExcelSheetColumns

End Sub
Sub DeleteExcelSheetColumns()
Worksheets("Sheet1").Range("A1:A1").Formula = "=COUNTIF(A7:BV7,""Plan Revenue"")"
If (ActiveCell.Value <> 5) Then

ActiveCell.Value = ""

DeleteGroupColumns Range("F1:N1")
DeleteGroupColumns Range("AD1:AL1")
DeleteGroupColumns Range("AG1:AO1")
DeleteGroupColumns Range("AJ1:AR1")
Worksheets("Sheet1").Range("B1:B1").Formula = "=COUNTIF(A7:BV7,""Plan Revenue"")"
ActiveCell.Value = ""
ActiveWorkbook.Save
End If
Caliculate

End Sub

Sub Caliculate()
Rem Q= r* S
Rem AL = AJ * AK

szStart = "17,8"
szEnd = "17,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 18) * ActiveSheet.Cells(nRow, 19)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
Rem AX = AV * AW --- w=u*V

szStart = "24,8"
szEnd = "24,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 22) * ActiveSheet.Cells(nRow, 23)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow

Rem BJ = BH * BI --- z=x*y
szStart = "26,8"
szEnd = "26,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 25) * ActiveSheet.Cells(nRow, 24)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
Rem BV = BT * BU AC=AA*AB

szStart = "29,8"
szEnd = "29,500"
Rem InputBox ("Please enter ending row, column")
sStartRowCol = Split(szStart, ",")
sEndRowCol = Split(szEnd, ",")
For nRow = sStartRowCol(0) To sEndRowCol(0)
For nColumn = sStartRowCol(1) To sEndRowCol(1)
If Not IsEmpty(ActiveSheet.Cells(nRow, 1)) Then
ActiveSheet.Cells(nRow, 8) = ActiveSheet.Cells(nRow, 27) * ActiveSheet.Cells(nRow, 28)
Rem SumWithCriteria(nRow, nColumn)
End If
Next nColumn
Next nRow
End Sub

RavishankerMaduriVBSCRIPT

Thursday, January 21, 2010

Automating Excel Using VBScript

Automating Excel Using VBScript

Followers

Blog Archive

About Me