Click here to edit title

lets learn together

Download


view:  full / summary

Generate CSV

Posted by [email protected] on March 17, 2017 at 11:40 AM Comments comments (0)

Sub Prince_GenerateCSV()

Dim xx As String

Dim MyPATH As String

Dim FileNAME As String

Application.ScreenUpdating = False

Application.DisplayAlerts = False

 

MyPATH = InputBox("Enter the path where you want to keep generated CSV files", "Enter the Path")

 

If MyPATH = vbNullString Then

MsgBox "Command Cancelled, Please retry", vbExclamation, "Command Cancelled"

Exit Sub

End If

 

 

With Application.FileDialog(msoFileDialogOpen)

.AllowMultiSelect = True

.Title = "Please select the required Text file"

.Filters.Clear

.Filters.Add "Excel Files", "*.xlsx"

.Show

For p = 1 To .SelectedItems.Count

xx = .SelectedItems(p)

Workbooks.Open (xx)

MyFileName = ActiveWorkbook.Name

master = ActiveWorkbook.Name

Application.StatusBar = " We are working on file name :---> " & master

lc = ActiveSheet.Range("XFD1").End(xlToLeft).Column

lr = ActiveSheet.Range("A1048576").End(xlUp).Row

 

temp = ""

n = ""

For r = 1 To lr

For c = 1 To lc

temp = Cells(r, c).Value

n = n & "|" & temp

Next

n = Right(n, Len(n) - 1)

Range("A" & r).Value = n

temp = "" ' Reseting Temp to blank Again

n = "" 'Reseting n to blank Again

Next

 

Rows(1).Delete shift:=xlUp

Range("B:XFD").ClearContents

FileNAME = ActiveWorkbook.Name

FileNAME = Left(FileNAME, Len(FileNAME) - 5) ' REMOVE XLS EXTENSION

FileNAME = FileNAME & ".csv" ' ADD CSV EXTENSION

Application.DisplayAlerts = False ' REMOVE DISPLAY MESSAGE: PREVIOUS FILE WILL BE ERASED

ActiveWorkbook.SaveAs FileNAME:= _

MyPATH & "\" & FileNAME, FileFormat:=xlCSV, _

CreateBackup:=False

ActiveWindow.Close

Application.DisplayAlerts = True ' RESTAURE DISPLAY MESSAGE

Next

 

Application.StatusBar = Clear

End With

MsgBox "CSV files generated Successfully; Please check on Below mentioned Location " & vbCrLf & vbCrLf & MyPATH

End Sub

 

Calibration

Posted by [email protected] on March 17, 2017 at 11:25 AM Comments comments (0)

Option Base 1

Sub Automation()

Dim data As Range

Application.DisplayAlerts = False

'Sheets("LookupData").Select

For Each Sheet In ActiveWorkbook.Worksheets

If Sheet.Name = "Summary" Then

Sheet.Delete

End If

Next

 

resp = MsgBox("Have you update severity infomation in Lookup Sheet ?", vbQuestion + vbYesNo, "Please select Appropriate")

If resp = vbYes Then

'------------

 

Sheets("LookupData").Select

Columns(4).Clear

Cells.Find(What:="Severity", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).EntireColumn.Copy Destination:=Columns(4)

ActiveSheet.Range("$D$1:$D$200").RemoveDuplicates Columns:=1, Header:=xlYes

'-----------------

Set data = Sheets("LookupData").Range("A1").CurrentRegion

Sheets("Master").Select

Cells.Clear

Master = ThisWorkbook.Name

With Application.FileDialog(msoFileDialogOpen)

.AllowMultiSelect = False

.Title = "Select the Callibration Template File"

If .Show = False Then

MsgBox "You have not selected Required file Hence exiting ; Please re-run the macro ", vbCritical, "Thomson Reuters"

Exit Sub

End If

xx = .SelectedItems(1)

Workbooks.Open (xx)

slave = ActiveWorkbook.Name

For Each Sheet In ActiveWorkbook.Worksheets

On Error Resume Next

If Sheet.Name = "Main" Then

Sheet.Select

Cells.Copy

Windows(Master).Activate

Sheets("Master").Activate

Range("A1").PasteSpecial xlPasteValues

Range("A1").PasteSpecial xlPasteFormats

Cells.Find(What:="Coding Sample", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Select

ActiveCell.EntireColumn.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

totrow = WorksheetFunction.CountA(ActiveCell.EntireColumn)

End If

Next Sheet

End With

Cells.EntireColumn.Hidden = False

Call Bordering

Call Clearformat

'

reqcolumn = Cells.Find("Coding Sample", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column

lastcolumn = Range("Xfd1").End(xlToLeft).Column

Range(Cells(1, reqcolumn + 2), Cells(1, lastcolumn)).Copy

Cells(1, lastcolumn).Offset(0, 1).PasteSpecial xlPasteValues

Cells(1, lastcolumn).Offset(0, 1).PasteSpecial xlPasteFormats

Worksheets.Add After:=Sheets(Worksheets.Count): ActiveSheet.Name = "Summary"

Range("A2").PasteSpecial Transpose:=True

Range("A1").Value = "Manager Names"

 

Sheets("Master").Select

Newstart = lastcolumn + 1

noofrow = WorksheetFunction.CountA(Columns(reqcolumn))

'codsamp = Cells.Find(what:="Coding Sample", After:=[a1], LookIn:=xlValues, Lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext).Column

orgcod = Cells.Find(What:="Original Coding", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column

'---------------------------- Replacements-----------------------------------------

Cells.Replace What:="yes", Replacement:="Yes"

Cells.Replace What:="YES", Replacement:="Yes"

Cells.Replace What:="yes ", Replacement:="Yes"

Cells.Replace What:="Yes ", Replacement:="Yes"

Cells.Replace What:=" Yes ", Replacement:="Yes"

Cells.Replace What:=" yes ", Replacement:="Yes"

totalyes = WorksheetFunction.CountIf(Cells, "Yes")

TotalMgr = lastcolumn - orgcod

For c = 1 To TotalMgr

For i = 2 To noofrow

Cells(i, Newstart).Select

test = Abs(StrComp(Cells(i, orgcod).Value, Cells(i, orgcod + c), vbTextCompare))

If test = 0 Then

Cells(i, Newstart).Value = 1

Else

Cells(i, Newstart).Value = 0

End If

Next

Newstart = Newstart + 1

Next

copycol = Cells.Find("Code", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column

Range(Cells(1, copycol), Cells(noofrow, copycol)).Copy

Worksheets.Add After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "Temp"

Range("a1").PasteSpecial xlPasteValues

Selection.SpecialCells(xlCellTypeBlanks).Select

Selection.FormulaR1C1 = "=R[-1]C"

Range("a1").CurrentRegion.Copy: Sheets("Master").Select

Range("Xfd1").End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteValues

Sheets("Temp").Delete

Range("Xfd1").End(xlToLeft).Offset(0, 1).Select: ActiveCell.Value = "Severity"

col = ActiveCell.Column - 1

For x = 2 To noofrow

Cells(x, col + 1).Value = Application.WorksheetFunction.VLookup(Cells(x, col), data, 2, 0)

Next x

Windows(slave).Close savechanges:=False

Call Bordering

Call Percentagecalculate

Call NewReport

MsgBox " Thank you for using this Tool The Report has been generated", vbInformation, "Thomson Reuters"

Else

MsgBox "Please update the lookup sheet first and re-run the macro", vbCritical, "Thomson Reuters"

End If

 

End Sub

 

Sub Clearformat()

sc = Range("Xfd1").End(xlToLeft).Column + 1

Range(Cells(1, sc), Cells(1048576, 16384)).ClearFormats

End Sub

 

Sub Percentagecalculate()

On Error Resume Next

Sheets("Summary").Select

lr = Range("A1048576").End(xlUp).Row

tot = WorksheetFunction.CountA(Sheets("LookupData").Range("D:D"))

ReDim Sever(tot)

 

For v = 2 To tot

Sever(v) = Sheets("LookupData").Range("D" & v).Value

Next

 

Sheets("Summary").Cells(1, 2).Value = "OverAll": Sheets("Summary").Cells(1, 3).Value = Sever(2)

Sheets("Summary").Cells(1, 4).Value = Sever(3): Sheets("Summary").Cells(1, 5).Value = Sever(4)

Sheets("Summary").Cells(1, 6).Value = Sever(5): Sheets("Summary").Cells(1, 7).Value = Sever(6)

 

Dim severity As Range

Set severity = Sheets("Master").Range("1:1").Find(What:="Severity", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).EntireColumn

 

 

For i = 2 To lr

x = Sheets("Summary").Range("A" & i).Value

Set myrange = Sheets("Master").Range("1:1").Find(What:=x, After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).EntireColumn

x = WorksheetFunction.Count(myrange)

y = WorksheetFunction.Sum(myrange)

n = y / x

Range("B" & i).Value = n

Range("B" & i).NumberFormat = "0.0%"

xx = WorksheetFunction.CountIf(severity, Sever(2))

yy = WorksheetFunction.SumIf(severity, Sever(2), myrange)

nn = yy / xx

Range("C" & i).Value = nn

Range("c" & i).NumberFormat = "0.0%"

xxx = WorksheetFunction.CountIf(severity, Sever(3))

yyy = WorksheetFunction.SumIf(severity, Sever(3), myrange)

nnn = yyy / xxx

Range("d" & i).Value = nnn

Range("d" & i).NumberFormat = "0.0%"

xxxx = WorksheetFunction.CountIf(severity, Sever(4))

yyyy = WorksheetFunction.SumIf(severity, Sever(4), myrange)

nnnn = yyyy / xxxx

Range("e" & i).Value = nnnn

Range("e" & i).NumberFormat = "0.0%"

' 4th fifth

xxxxx = WorksheetFunction.CountIf(severity, Sever(5))

yyyyy = WorksheetFunction.SumIf(severity, Sever(5), myrange)

nnnnn = yyyyy / xxxxx

Range("f" & i).Value = nnnnn

Range("f" & i).NumberFormat = "0.0%"

xxxxxx = WorksheetFunction.CountIf(severity, Sever(6))

yyyyyy = WorksheetFunction.SumIf(severity, Sever(6), myrange)

nnnnnn = yyyyyy / xxxxxx

Range("g" & i).Value = nnnnnn

Range("g" & i).NumberFormat = "0.0%"

'

Next i

 

Call Bordering

 

 

End Sub

Sub NewReport()

Dim Wb1 As Workbook

Dim Wb2 As Workbook

Dim dateStr As String

Dim myDate As Date

 

With Application

.ScreenUpdating = False

.DisplayAlerts = False

.EnableEvents = False

End With

 

Set Wb1 = ActiveWorkbook

 

myDate = Date

 

dateStr = Format(myDate, "MM-DD-YY")

 

Set Wb2 = Application.Workbooks.Add(1)

Wb1.Sheets(Array(Wb1.Sheets(2).Name, Wb1.Sheets(4).Name)).Copy Before:=Wb2.Sheets(1)

Wb2.Sheets(Wb2.Sheets.Count).Delete

 

Dim bFileSaveAs As Boolean

bFileSaveAs = Application.Dialogs(xlDialogSaveAs).Show

If Not bFileSaveAs Then MsgBox "User cancelled", vbCritical

 

' Wb2.SaveAs Filename:="U:\For Prince\02. Adhoc Work\11. Hari\Callibration Generated\" & " " & "Callibration Sheet " & dateStr ', FileFormat:=51

'

' Wb2.Close

With Application

.ScreenUpdating = True

.DisplayAlerts = True

.EnableEvents = True

End With

End Sub

 

Sub Bordering()

 

With Cells

.Borders(xlDiagonalDown).LineStyle = xlNone

.Borders(xlDiagonalUp).LineStyle = xlNone

.Borders(xlEdgeLeft).LineStyle = xlNone

.Borders(xlEdgeTop).LineStyle = xlNone

.Borders(xlEdgeBottom).LineStyle = xlNone

.Borders(xlEdgeRight).LineStyle = xlNone

.Borders(xlInsideVertical).LineStyle = xlNone

.Borders(xlInsideHorizontal).LineStyle = xlNone

End With

With Range("A1").CurrentRegion

.Borders(xlEdgeLeft).LineStyle = xlContinuous

.Borders(xlEdgeTop).LineStyle = xlContinuous

.Borders(xlEdgeBottom).LineStyle = xlContinuous

.Borders(xlEdgeRight).LineStyle = xlContinuous

.Borders(xlInsideVertical).LineStyle = xlContinuous

.Borders(xlInsideHorizontal).LineStyle = xlContinuous

End With

Cells.Interior.Pattern = xlNone

Cells.Font.Bold = False

LC = Range("XFD1").End(xlToLeft).Column

Range(Cells(1, 1), Cells(1, LC)).Interior.ColorIndex = 36

Range("A1").CurrentRegion.EntireColumn.AutoFit

End Sub

 

 

 

UserForm-GNRP

Posted by [email protected] on March 17, 2017 at 11:20 AM Comments comments (0)

 

 

Private Sub CmbQC_Enter()

CmbQC.Clear

countqc = Sheets("Misc").Range("D1048576").End(xlUp).Row

For i = 2 To countqc

CmbQC.AddItem Sheets("Misc").Range("D" & i).Value

Next

End Sub

 

Private Sub CommandButton2_Click()

Unload Me

End Sub

 

Private Sub Frame2_Click()

 

End Sub

 

Private Sub TextBox7_Change()

 

End Sub

 

Private Sub UserForm_Activate()

Sheets("RawData").Select

TxtUID.SetFocus

TextBox9.Value = Application.UserName

TextBox8.Value = Date

lr = Sheets("Misc").Range("C1048576").End(xlUp).Row

For i = 2 To lr

CmbSubOption.AddItem Range("C" & i).Value

Next

End Sub

Private Sub CmbFLR_Enter()

CmbFLR.Clear

countqc = Sheets("Misc").Range("A1048576").End(xlUp).Row

For i = 2 To countqc

CmbFLR.AddItem Sheets("Misc").Range("A" & i).Value

Next

End Sub

Private Sub CmbCountry_Enter()

CmbCountry.Clear

lr = Sheets("Misc").Range("B1048576").End(xlUp).Row

For i = 2 To lr

CmbCountry.AddItem Sheets("Misc").Range("B" & i).Value

Next

End Sub

Private Sub CmbCountry_Change()

CmbSubOption.Clear

xx = CmbCountry.Value

sc = Sheets("RawData").Range("1:1").Find(what:=xx, after:=[Az1], LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows).Column

 

lngLastRow = Cells(Rows.Count, sc).End(xlUp).Row

 

For i = 2 To lngLastRow

CmbSubOption.AddItem Cells(i, sc)

Next

End Sub

Private Sub CmbSubOption_Change()

Opportunities.Clear

xx = CmbSubOption.Value

sc = Range("1:1").Find(what:=xx, after:=[Az1], LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows).Column

 

lngLastRow = Cells(Rows.Count, sc).End(xlUp).Row

 

For i = 2 To lngLastRow

Opportunities.AddItem Cells(i, sc)

Next

End Sub

 

 

Private Sub CommandButton1_Click()

sp = Sheet1.Range("H1048576").End(xlUp).Row + 1

For i = 0 To Opportunities.ListCount - 1

llr = Range("H1048576").End(xlUp).Row + 1

If Opportunities.Selected(i) = True Then

Sheet1.Range("H" & llr).Value = Opportunities.List(i)

End If

Next i

 

 

ep = Sheet1.Range("H1048576").End(xlUp).Row

 

Range(Cells(sp, 1), Cells(ep, 1)).Value = TxtUID.Value

Range(Cells(sp, 20), Cells(ep, 20)).Value = TxtNP.Value

Range(Cells(sp, 2), Cells(ep, 2)).Value = CmbFLR.Value

 

' Date Combos

 

dd = UserForm1.CmbFdd.Value

mm = UserForm1.CmbFMM.Value

yy = UserForm1.CmbFYY.Value

dd = Val(dd)

mm = Val(mm)

yy = Val(yy)

Range(Cells(sp, 3), Cells(ep, 3)) = DateSerial(yy, mm, dd)

 

'-

 

 

Range(Cells(sp, 4), Cells(ep, 4)).Value = "QC Name"

'----------------

 

ddd = UserForm1.CmbQDD.Value

mmm = UserForm1.CmbQMM.Value

yyy = UserForm1.CmbQYY.Value

ddd = Val(ddd)

mmm = Val(mmm)

yyy = Val(yyy)

 

Range(Cells(sp, 5), Cells(ep, 5)).Value = DateSerial(yyy, mmm, ddd)

'-----------------

 

Range(Cells(sp, 6), Cells(ep, 6)).Value = CmbCountry.Value

Range(Cells(sp, 7), Cells(ep, 7)).Value = CmbSubOption.Value

 

 

Range(Cells(sp, 9), Cells(ep, 9)).Value = ComboBox7.Value

Range(Cells(sp, 10), Cells(ep, 10)).Value = ComboBox8.Value

Range(Cells(sp, 11), Cells(ep, 11)).Value = ComboBox9.Value

Range(Cells(sp, 12), Cells(ep, 12)).Value = ComboBox10.Value

Range(Cells(sp, 13), Cells(ep, 13)).Value = ComboBox11.Value

Range(Cells(sp, 14), Cells(ep, 14)).Value = ComboBox12.Value

 

MsgBox " The Data has been submitted"

 

Dim Ctrl As Control

For Each Ctrl In Me.Controls

If TypeOf Ctrl Is MSForms.ComboBox Then

On Error Resume Next

Ctrl.Clear

End If

Next Ctrl

 

 

For Each Ctrl In Me.Controls

If TypeName(Ctrl) = "TextBox" Then

Ctrl.Text = ""

End If

Next Ctrl

TxtUID.SetFocus

End Sub

 

 

 

 

 

 

 

Userform List Box Concept

Posted by [email protected] on March 17, 2017 at 11:20 AM Comments comments (0)

 

 

Private Sub CmbSubDD_Exit(ByVal Cancel As MSForms.ReturnBoolean)

dd = Val(CmbSubDD): mm = Val(CmbSubMM): yy = Val(CmbSubYY):

If dd <> 0 And mm <> 0 And yy <> 0 Then

CmbPend.Visible = False

Label32.Visible = False

Else

CmbPend.Visible = True

Label32.Visible = True

End If

End Sub

 

 

Private Sub CmbSubMM_Exit(ByVal Cancel As MSForms.ReturnBoolean)

dd = Val(CmbSubDD): mm = Val(CmbSubMM): yy = Val(CmbSubYY):

If dd <> 0 And mm <> 0 And yy <> 0 Then

CmbPend.Visible = False

Label32.Visible = False

Else

CmbPend.Visible = True

Label32.Visible = True

End If

End Sub

 

Private Sub CmbSubYY_Exit(ByVal Cancel As MSForms.ReturnBoolean)

dd = Val(CmbSubDD): mm = Val(CmbSubMM): yy = Val(CmbSubYY):

If dd <> 0 And mm <> 0 And yy <> 0 Then

CmbPend.Visible = False

Label32.Visible = False

Else

CmbPend.Visible = True

Label32.Visible = True

End If

End Sub

 

Private Sub CommandButton2_Click()

Unload Me

End Sub

Private Sub CommandButton1_Click()

'Created by Prince Sethi

' On 14 Mar. 2017

Application.DisplayAlerts = False

 

If CmbProj = "" Or CmbSale = "" Or CmbDelivery = "" Or CmbRfpDD = "" Or CmbRfpMM = "" Or CmbRfpYY = "" Or CmbRespDD = "" Or CmbRespMM = "" Or CmbRespYY = "" Or CmbActDD = "" Or CmbActMM = "" Or CmbActYY = "" Or CmbType = "" Or CmbBELead = "" Or CmbReqDD = "" Or CmbReqMM = "" Or CmbReqYY = "" Then

MsgBox "Please fill all the required field"

Exit Sub

End If

 

 

On Error Resume Next

Sheets("RawData").Select

SP = Sheets("RawData").Range("H1048576").End(xlUp).Row + 1

For i = 0 To LstREquirement.ListCount - 1

llr = Range("H1048576").End(xlUp).Row + 1

If LstREquirement.Selected(i) = True Then

Sheets("RawData").Range("H" & llr).Value = LstREquirement.List(i)

End If

Next i

For i = 0 To BEOwner.ListCount - 1

If BEOwner.Selected(i) = True Then

temp = temp & "," & BEOwner.List(i)

End If

Next i

 

temp = Right(temp, Len(temp) - 1)

 

ep = Sheets("RawData").Range("H1048576").End(xlUp).Row

Sheets("RawData").Range(Cells(SP, 9), Cells(ep, 9)).Value = temp

With Sheets("RawData")

.Range(Cells(SP, 1), Cells(ep, 1)).Value = CmbProj

.Range(Cells(SP, 2), Cells(ep, 2)).Value = CmbSale

.Range(Cells(SP, 3), Cells(ep, 3)).Value = CmbDelivery

dd = Val(CmbRfpDD): mm = Val(CmbRfpMM): yy = Val(CmbRfpYY):

If dd = 0 Or mm = 0 Or yy = 0 Then

Range(Cells(SP, 4), Cells(ep, 4)) = ""

Else

Range(Cells(SP, 4), Cells(ep, 4)) = DateSerial(yy, mm, dd)

End If

dd = Val(CmbRespDD): mm = Val(CmbRespMM): yy = Val(CmbRespYY):

If dd = 0 Or mm = 0 Or yy = 0 Then

Range(Cells(SP, 5), Cells(ep, 5)) = ""

Else

Range(Cells(SP, 5), Cells(ep, 5)) = DateSerial(yy, mm, dd)

End If

dd = Val(CmbActDD): mm = Val(CmbActMM): yy = Val(CmbActYY):

If dd = 0 Or mm = 0 Or yy = 0 Then

Range(Cells(SP, 6), Cells(ep, 6)) = ""

Else

Range(Cells(SP, 6), Cells(ep, 6)) = DateSerial(yy, mm, dd)

End If

.Range(Cells(SP, 7), Cells(ep, 7)).Value = CmbType

.Range(Cells(SP, 10), Cells(ep, 10)).Value = CmbBELead

dd = Val(CmbReqDD): mm = Val(CmbReqMM): yy = Val(CmbReqYY):

If dd = 0 Or mm = 0 Or yy = 0 Then

Range(Cells(SP, 11), Cells(ep, 11)) = ""

Else

Range(Cells(SP, 11), Cells(ep, 11)) = DateSerial(yy, mm, dd)

End If

dd = Val(CmbSubDD): mm = Val(CmbSubMM): yy = Val(CmbSubYY):

If dd = 0 Or mm = 0 Or yy = 0 Then

Range(Cells(SP, 12), Cells(ep, 12)) = ""

Else

Range(Cells(SP, 12), Cells(ep, 12)) = DateSerial(yy, mm, dd)

End If

 

Debug.Print DateSerial(yy, mm, dd)

.Range(Cells(SP, 13), Cells(ep, 13)).Value = CmbPend

.Range(Cells(SP, 14), Cells(ep, 14)).Value = TxtComment

End With

Call Cleardata

CmbPend.Visible = True

Label32.Visible = True

End Sub

Private Sub UserForm_Activate()

TxtUser = Application.UserName

TxtDate = Date

TxtTime = Time

End Sub

 

Sub Cleardata()

CmbProj = Clear

CmbSale = Clear

CmbDelivery = Clear

CmbRfpDD = Clear

CmbRfpMM = Clear

CmbRfpYY = Clear

CmbRespDD = Clear

CmbRespMM = Clear

CmbRespYY = Clear

CmbActDD = Clear

CmbActMM = Clear

CmbActYY = Clear

CmbType = Clear

CmbBELead = Clear

CmbReqDD = Clear

CmbReqMM = Clear

CmbReqYY = Clear

CmbSubDD = Clear

CmbSubMM = Clear

CmbSubYY = Clear

CmbPend = Clear

TxtComment = Clear

For i = 0 To LstREquirement.ListCount - 1

If LstREquirement.Selected(i) = True Then

LstREquirement.Selected(i) = False

End If

Next i

For i = 0 To BEOwner.ListCount - 1

If BEOwner.Selected(i) = True Then

BEOwner.Selected(i) = False

End If

Next i

 

End Sub

 

 

 

Refresh All pivot Table in Workbook

Posted by [email protected] on March 17, 2017 at 11:15 AM Comments comments (1)

Sub RefreshPivots()

Dim pt As PivotTable

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

For Each pt In ws.PivotTables

pt.RefreshTable

Next pt

Next ws

 

End Sub

 

Chart on MouseOver

Posted by [email protected] on March 17, 2017 at 11:15 AM Comments comments (0)

Public Function highlightSeries(seriesName As Range)

 

If Range("valSelOption") <> seriesName.Value Then Range("valSelOption") = seriesName.Value

 

End Function

 

Send Email Through VBA

Posted by [email protected] on March 17, 2017 at 11:15 AM Comments comments (0)

Option Explicit

 

Sub CreateEmail()

 


Dim sSubject As String

Dim sSend_From As String

Dim sSend_To As String

Dim sCc As String

Dim sBcc As String

Dim sBody As String

Dim objMail_Object As Object

Dim objMail_Single As Object

Dim rDist As Range

Dim wbDash As Workbook

Dim sTempFilePath As String

Dim sTempFileName As String

Dim sFileExt As String

 

With Application

.ScreenUpdating = False

.EnableEvents = False

End With

 

On Error GoTo ErrorHandle

 

Set wbDash = ActiveWorkbook

wbDash.Save

 

'Save temporary copy of the file

sTempFilePath = Environ$("temp") & "\"

sTempFileName = Format(Now, "dd-mmm-yy h-mm-ss") & " - " & wbDash.Name

wbDash.SaveCopyAs sTempFilePath & sTempFileName

 

'Define Email Attributes

sSubject = Format(Now, "dd-mmm-yy") & " - Daily FRC Report"

sSend_From = "[email protected]"

 

'Set Sent_To List

For Each rDist In [Data_Dist].Rows

If Intersect(rDist, [Data_Dist[To:]]).Value Like "*@*" Then

sSend_To = sSend_To & ";" & Intersect(rDist, [Data_Dist[To:]]).Value

End If

Next

'Set Sent_To List

For Each rDist In [Data_Dist].Rows

If Intersect(rDist, [Data_Dist[CC:]]).Value Like "*@*" Then

sCc = sCc & ";" & Intersect(rDist, [Data_Dist[CC:]]).Value

End If

Next

'Set Sent_To List

For Each rDist In [Data_Dist].Rows

If Intersect(rDist, [Data_Dist[BCC:]]).Value Like "*@*" Then

sBcc = sBcc & ";" & Intersect(rDist, [Data_Dist[BCC:]]).Value

End If

Next

 

'Set Body of email

sBody = "Hi All," & _

"

Please find the latest status update for the FRC project attached." & _

"
Please let us know if there are any questions or concerns." & _

"

Kind Regards."

 

'Create Email

Set objMail_Object = CreateObject("Outlook.Application")

Set objMail_Single = objMail_Object.CreateItem(0)

 

With objMail_Single

.Subject = sSubject

.To = sSend_To

.cc = sCc

.BCC = sBcc

.HTMLBody = sBody

.Attachments.Add sTempFilePath & sTempFileName

'.Attachments.Add ActiveWorkbook.FullName

'.Attachments.Add ("C:\test.txt")

.Display

'.Send

End With

 

'Delete the file

Kill sTempFilePath & sTempFileName

 

ErrorHandle:

If Err.Description <> "" Then MsgBox Err.Description

 

Set objMail_Object = Nothing

Set objMail_Single = Nothing

 

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

 

End Sub

 

Autosum

Posted by [email protected] on May 7, 2015 at 11:45 AM Comments comments (0)

Sub Autosum_generated()

'Dim x As Range

Dim lr As Integer

lr = Range("A65536").End(xlUp).Row

For j = lr To 3 Step -1

If Range("A" & j).Value <> Range("A" & j - 1).Value Then

Range("A" & j).EntireRow.Insert shift:=xlDown

End If

Next

 

Range("D1").Select

ActiveSheet.UsedRange

 

lr1 = Range("D65536").End(xlUp).Row

 

Set tot = Range("D2:D" & lr1)

 

For Each cell In tot

On Error GoTo Handler:

sp = ActiveCell.Row + 1

ActiveCell.End(xlDown).Select

ep = ActiveCell.Row

TR = ep - sp

ActiveCell.Offset(1, 0).Select

x = Range(Cells(sp, 4), Cells(ep, 4)).Address

n = Application.WorksheetFunction.Sum(Range(x).Value)

ActiveCell.Value = n

Next

Handler:

Range("A1").Select

Exit Sub

End Sub

 

 

 

Macro

Posted by [email protected] on May 7, 2015 at 11:45 AM Comments comments (0)

Sub ListDownName()

i = 1

For Each sh In ActiveWorkbook.Worksheets

Range("A" & i).Value = sh.Name

i = i + 1

Next

End Sub

 

Sub Browsefileand_listdowntheirname()

 

With Application.FileDialog(msoFileDialogOpen)

.AllowMultiSelect = True

.Show

For i = 1 To .SelectedItems.Count

yy = .SelectedItems(i)

Range("B" & i).Value = Extractfilename(yy)

Next

 

End With

End Sub

 

 

Function Extractfilename(url As Variant) As String

x = 0

For i = 1 To Len(url)

If Mid(url, i, 1) = "\" Then

x = x + 1

End If

Next

n = Application.WorksheetFunction.Substitute(url, "\", "@", x)

m = Application.WorksheetFunction.Search("@", n) + 1

Extractfilename = Trim(Mid(url, m, Len(url)))

End Function

 

 

Sub Filtereddata()

Dim rng As Range

Set rng = Sheet1.Range("A1").CurrentRegion

x = InputBox("Enter the name to whom you want to filter")

rng.AutoFilter Field:=1, Criteria1:=x

Cells.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheet2.Range("A1")

End Sub

 

Sub conversiontexttovalue()

For Each cell In Range("A1").CurrentRegion

cell.Select

If cell = WorksheetFunction.IsText(cell) Then

cell.Value = Val(cell)

End If

Next

End Sub

 

File System in VBA - Macro

Posted by [email protected] on June 5, 2014 at 10:10 AM Comments comments (0)

Excel File can be downloaded from below path

https://drive.google.com/file/d/0B1XLV4eCY-dcbHFSbi1mNWk1d1k/edit?usp=sharing

Video File can be downloaded from below path

https://www.youtube.com/watch?v=ouJ8O5nhMEg


Rss_feed