ALL Macros ASK

  Selection.NumberFormat = "0.00" --------------- =OFFSET(G1094,-1,0)/OFFSET(G1094,-12,0)-1 ---------------- Sub test() ' to select all sheets in the summary workbook Dim i As Long Sheet1.Select For i = 2 To ThisWorkbook.Sheets.Count     If Sheets(i).Name <> "Summary" Then Sheets(i).Select Replace:=False Next i End Sub  --------------- Sub LastRowInOneColumn()  'Find the last used row in a Column: column F in this     Dim LastRow As Long     With ActiveSheet         LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row     End With     MsgBox LastRow End Sub --------------------------------- Sub tests() ' to place vlookup in each and every sheet other than summary Dim i As Long Sheet1.Select For i = 2 To ThisWorkbook.Sheets.Count     If Sheets(i).Name <> "Summary" Then Sheets(i).Select Replace:=False     a = Range("f7").End(xlDown).Row ...

Dim shtcount, mshtcount, i, counter As Integer 'for timer Dim StartTime As Double Dim SecondsElapsed As Double 'Remember time when macro starts   StartTime = Timer 'code  SecondsElapsed = Round(Timer - StartTime, 2) MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation ----- '1) to add all excels to summary workbook which contains yes in summary sheet Sub DoThis()     Dim shSummary As Worksheet         Dim c As Range, wbk As Workbook         Set shSummary = Sheets("Summary")         With Summary         For Each c In shSummary.Range("B1:" & shSummary.Range("B1").End(xlDown).Address)             If UCase(c.Value) = UCase("YES") Then                 If dir("\\s\d\Desktop\ALL indexs\" & c.Previous & ".xlsx") <> "" Then  ...

Sub outlookmailxlsheet()     Dim rng As Range     Dim OutApp As Object     Dim OutMail As Object       Set rng = Nothing     Set rng = Sheets("YourSheet").UsedRange     Set OutApp = CreateObject("Outlook.Application")     Set OutMail = OutApp.CreateItem(0)     On Error Resume Next     With OutMail         .To = "XX@gmail.com"         .CC = ""         .BCC = ""         .Subject = "This is the Subject line"         .HTMLBody = RangetoHTML(rng)         .Send   'or use .Display     End With     With Application         .EnableEvents = True         .ScreenUpdating = True     End With     Set OutMail = Nothing     Set OutApp = Nothing End Sub Fun...

To add sheets: Sheets.Add after:=Sheets(Sheets.count) ---------------------------------------- Sub togetsheenames() Dim i As Integer Dim sh As String For i = 1 To Sheets.Count sh = Sheets(i).Name Sheets("ToDelete").Range("A" & i) = sh Next End Sub -------------------------- fill lookup formula  Range("D3").Select ActiveCell.Formula = "=VLOOKUP(A3,Exp!$B:$E,4,0)"     Range("d3").AutoFill Range("d3:d" & Range("a1").End(xlDown).Row) ------------------ Hide sheet Sheets("Sheet2").Visible = True unhide sheet  Sheets("Sheet2").Visible = Flase --------------------------------------------- For i = 2 To drcount mystng = Sheets("Counter").Range("A" & i).Value LR = Sheets("Rough").Range("A1").CurrentRegion.Rows.Count + 1 Sheets(2).Select Sheets(2).Rows("3:3").AutoFilter Field:=26, Criteria1:=m...

Sub FindingLastRow() 'PURPOSE: Different ways to find the last row number of a range Dim sht As Worksheet Dim LastRow As Long Set sht = ActiveSheet 'Using Find Function (Provided by Bob Ulmas)   LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'Using SpecialCells Function   LastRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row 'Ctrl + Shift + End   LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 'Using UsedRange   sht.UsedRange 'Refresh UsedRange   LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row 'Using Table Range   LastRow = sht.ListObjects("Table1").Range.Rows.Count 'Using Named Range   LastRow = sht.Range("MyNamedRange").Rows.Count 'Ctrl + Shift + Down (Range should be first cell in data set)   LastRow = sht.Range("A1").CurrentRegion.Rows.Count End Sub ######################################################...

Sub CLE() 'ONEYEAR DATA Sheets("Sheet2").Select 'Range("j10: L110 ").ClearContents 'FSTR = InputBox("Enter the date.. You wanted to See !") lastrow = Sheets("sheet2").UsedRange.Rows.Count On Error GoTo sant For I = 6 To lastrow If Range("C" & I) <> "" Then fstr = Sheets("sheet2").Range("c" & I).Value Sheets("Sheet1").Select             Cells.Find(What:=fstr, After:=ActiveCell, _             LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _             SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate             'ActiveCell.CurrentRegion.Select A = ActiveCell.Row 'MsgBox A + 2 A = A + 2 Range("f" & A).Select     Selection.Copy     Sheets("Sheet2").Select     Range("e" & I).Select     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, ...

to filter the data Sub Analyst() Dim role As String role = Sheets(1).Cells(3, 2).Value Sheets(2).AutoFilterMode = False  Sheets(2).UsedRange.AutoFilter Field:=11, Criteria1:="=*" & role & "*" 'Operator:=xlAnd, Field:=9, Criteria2:="<>*" & role & "*" 'Sheets(2).UsedRange.AutoFilter Field:=11, Criteria1:="*"role, Operator:=xlAnd, Field:=9, Criteria2:="<>*role*" Sheets(2).UsedRange.AutoFilter Field:=9, Criteria1:="<>*" & role & "*" Sheets(2).UsedRange.Copy Sheets(1).Range("a11") Sheets(1).AutoFilterMode = False End Sub

Sub TestNotePad()     '// The range to copy - written freehand so change as needed     Range("A1:B55").Copy         '// Start Notepad with focus     Shell "notepad.exe", vbNormalFocus         '// Send the standard CTRL+V. Pastes to the     '// active window (Notepad, hopefully)     SendKeys "^V"     '// Back to the top of the file     SendKeys "^{HOME}"     End Sub ------------------- cebu1014 Author Commented: 2013-05-22 I got it to work using your above routine as a guide. I removed some of the lines though and added  TRUE at end of sendkeys command in order to get it to work. Sub CopyToNotepad()              Range("A1").Select     Range(Selection, Selection.End(xlDown)).Select     Selection.Copy       Shell "Notepad C:\Users\mw1\my Documents\abc.csv", vbNor...

'Delete filter data except header Sub redfdf() Sheets(1).Range("a1").Select Selection.AutoFilter Sheets(1).UsedRange.AutoFilter Field:=2, Criteria1:="Income" Sheets(1).UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sheets(2).Range("A2") Sheets(1).UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select Selection.EntireRow.Delete End Sub

Sub CopyByHeader()     Dim CurrentWS As Worksheet     Set CurrentWS = ActiveSheet     Dim SourceWS As Worksheet     Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)     Dim SourceHeaderRow As Integer: SourceHeaderRow = 1     Dim SourceCell As Range     Dim TargetWS As Worksheet     Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)     Dim TargetHeader As Range     Set TargetHeader = TargetWS.Range("A1:AX1")     Dim RealLastRow As Long     Dim SourceCol As Integer     SourceWS.Activate     For Each Cell In TargetHeader         If Cell.Value <> "" Then             Set SourceCell = Rows(SourceHeaderRow).Find _                 (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)           ...

sub ds() mypath = ThisWorkbook.Path & "\1.RAWFILES\" myfile = Dir(mypath & "ad*.csv")   Workbooks.Open Filename:=mypath & myfile, ReadOnly:=False   Set mywbk1 = ActiveWorkbook   mywbk1.Activate   Sheets(1).Select Range("a1").CurrentRegion.Copy mywbk.Sheets("ad).Range("a1") mywbk1.Close SaveChanges:=False end sub

'In this Example I am Copying the File From "s" Folder to "sd" Folder Sub sbCopyingAFile() 'Declare Variables Dim FSO Dim sFile As String Dim sSFolder As String Dim sDFolder As String 'This is Your File Name which you want to Copy sFile = "Sample.xls" 'Change to match the source folder path sSFolder = "C:\s\" 'Change to match the destination folder path sDFolder = "D:\sd\" 'Create Object Set FSO = CreateObject("Scripting.FileSystemObject") 'Checking If File Is Located in the Source Folder If Not FSO.FileExists(sSFolder & sFile) Then MsgBox "Specified File Not Found", vbInformation, "Not Found" 'Copying If the Same File is Not Located in the Destination Folder ElseIf Not FSO.FileExists(sDFolder & sFile) Then FSO.CopyFile (sSFolder & sFile), sDFolder, True MsgBox "Specified File Copied Successfully", vbInformation, "Done!"...

Sub testd() Sheets(1).Select Sheets(1).Range("a1").CurrentRegion.Select Selection.Copy Sheets(2).Range("a1") Sheets(2).Select a = Range("A1").CurrentRegion.Columns.Count k = 1 l = 1 Columns(a).Select Selection.Delete shift:=xlToLeft For i = 3 To a Sheets(2).Select     Rows("2:2").Select     Selection.AutoFilter     ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:=">=0.04", Operator:=xlOr, Criteria2:="<=-0.04" ActiveSheet.Columns("a:C").Copy Sheets(3).Cells(k, l) 'l = Sheets(3).Range("a" & l).CurrentRegion.Columns.Count l = Sheets(3).UsedRange.Columns.Count l = l + 2 Sheets(2).Select Selection.AutoFilter Sheets(2).Columns("C").Select Selection.Delete shift:=xlToLeft Next End Sub

This example copies worksheets Sheet1, Sheet2 and Sheet4 to a new blank workbook, then saves and closes the new workbook. VB Copy Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy With ActiveWorkbook      .SaveAs Filename:=Environ("TEMP") & "\New3.xlsx", FileFormat:=xlOpenXMLWorkbook      .Close SaveChanges:=False End With

combine sheets into one book and all sheets into one sheet Sub getdata_Fromallbooks() ' Path = ThisWorkbook.Path & "\st\" Filename = Dir(Path & "*.xls")   Do While Filename <> ""   Workbooks.Open Filename:=Path & Filename, ReadOnly:=True      For Each Sheet In ActiveWorkbook.Sheets      Sheet.Copy After:=ThisWorkbook.Sheets(1)   Next Sheet      Workbooks(Filename).Close      Filename = Dir()   Loop End Sub Sub Combine()     Dim J As Integer     On Error Resume Next     Sheets(1).Select     Worksheets.Add ' add a sheet in first place     Sheets(1).Name = "Combined"     ' copy headings     Sheets(2).Activate     Range("A1").EntireRow.Select     Selection.Copy Destination:=Sheets(1).Range("A1")     ' work through sheets     For J = 2 To Sheets.Count ' ...

" to downlad only excels from a specific foloder of inbox to a folder which we give" Sub TodownloadAttachments() 'delcare variables     Dim ns As NameSpace     Dim inbox As MAPIFolder     Dim item As Object     Dim Atmt As Attachment     Dim filename As String     Dim SubFolder As MAPIFolder     Dim i As Integer     Dim fol As String 'set varilables fol = InputBox("enter folder name") Set ns = GetNamespace("MAPI")  Set inbox = ns.GetDefaultFolder(olFolderInbox) Set SubFolder = inbox.Folders(fol)  i = 0  For Each item In SubFolder.Items     For Each Atmt In item.Attachments        filename = "\\d\a\Desktop\s\" & Atmt.filename        Atmt.SaveAsFile filename        i = i + 1     Next Atmt  Next item   End Sub --------------------------------------------------------...

Check if Folder Exists using Excel VBA 'In this Example I am checking if "C:\Temp" exits Sub sbCheckingIfAFolderExists() Dim FSO Dim sFolder As String sFolder = "C:\Temp" ' You can Specify Any Folder To Check It Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FolderExists(sFolder) Then MsgBox "Specified Folder Is Available", vbInformation, "Exists!" Else MsgBox folder &"Specified Folder Not Found", vbInformation, "Not Found!" End If End Sub ------------------------ Opening Folders using VBA Excel 'In this Example I am Opening a Folder ("C:\Temp") Sub sbOpeningAFolder() Dim FSO Dim sFolder As String sFolder = "C:\Temp" 'You can specify your Folder which you wants to Open Set FSO = CreateObject("Scripting.FileSystemObject") If Not FSO.FolderExists(sFolder) Then MsgBox "Specified Folder Not Found", vbInformation, ...

Business unit overview Sub BUOVW() Call RetrieveFile Call forsheetscreation Call copycomplexdataintomaster Call todeletedefaluts Call toreplaceNA Call TransferData End Sub Sub RetrieveFile() ' to populate  message if files are not there file = ThisWorkbook.Path & "\1.Raw Files\*.*" 'file = Dir("\\c\aku4\Desktop\Business unit overview\TEST\*.*") If Len(file) > 0 Then  MsgBox (" Files are Exists.. and continuing the macro") Else  MsgBox ("File Doesn't Exists") End If End Sub ' to get each and every file name Sub paths() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim i As Integer file = ThisWorkbook.Path & "\1.Raw Files" 'Create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'Get the folder object 'Set objFolder = objFSO.GetFolder("\\c\aku4\Desktop\Business unit overview\TEST") Se...

to apply every 7th row a formula Sub a() TC = ActiveSheet.UsedRange.Rows.count For i = TC To 1 Step -7     If i >= 7 Then         Cells(i, 3).Formula = "=Average(" & Cells(i, 2).Address & ":" & Cells(i - 6, 2).Address & ")"     Else         Cells(i, 3).Formula = "=Average(" & Cells(1, 2).Address & ":" & Cells(i, 2).Address & ")"     End If LI = i Next end sub -----------------------------------------------------------------------------------  apply bookmarks to each and every page on pdf based on sources in another excel Option Explicit Sub GetRWRReportBookmarks() Dim Exch As Object Dim AVDoc As Object Dim AVPageView As Object Dim PDDoc As Object Dim PDPage As Object Dim PDText As Object Dim PDBookmark As Object Dim numPages As Integer Dim bFile As Boolean Dim bShow As Boolean Dim iPageNumber As Integer Dim i As Long, j As Long D...

Aim clean filter Option Explicit Sub update_data() Application.ScreenUpdating = False Application.DisplayAlerts = False Application.StatusBar = "Processing... Please Be Patient." Sheets("Sheet2").Visible = True Sheets("Result").Visible = True Sheets("ResultMTD").Visible = True Sheets("MTD_Month").Visible = True Call FORMAT_DATA Call mtd_toresult Call mtd_tomonth_result Application.ScreenUpdating = True Application.StatusBar = False Application.DisplayAlerts = True Sheets("Macro").Select MsgBox " ! Done ! " Sheets("Sheet2").Visible = False Sheets("Result").Visible = False Sheets("ResultMTD").Visible = False Sheets("MTD_Month").Visible = False End Sub Sub FORMAT_DATA() Dim i As Integer Dim k As Integer Dim l As Integer Dim a As Integer Sheets("Sheet2").Select Cells.Clear Sheets("Result").Select Cells.Clear Sheets(...