Sunday, April 21, 2019
Another way to copy data and create new workbook and paste it
Another way to copy data and create new workbook and paste it
Sub CopyItOver()
Set Newbook = Workbooks.Add
Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Worksheets("Master Order Template").Copy
Newbook.Worksheets("Sheet1").PasteSpecial Paste:=xlPasteValues
' NewBook.SaveAs Filename:=NewBook.Worksheets("Sheet1").Range("E3").Value
'ThisWorkbook.Close Savechanges = False
End Sub
Sub CopyOver2()
Dim newWB As Workbook, currentWB As Workbook
Dim newS As Worksheet, currentS As Worksheet
Dim xStrDate As String
Dim xFileName As String
Dim xJBName As String
Dim xLocation As String
'Copy the data you need
'Set currentWB = ThisWorkbook
Set currentS = Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Sheets("MASTER ORDER TEMPLATE")
currentS.Range("A:AT").Select
Selection.Copy
'Create a new file that will receive the data
xStrDate = Format(Now, "mmdd_hhmm")
xJBName = Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Sheets("Store Input").Range("B9").Value & "_"
xLocation = Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Sheets("Store Input").Range("$J$24").Value
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Sheet1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
newS.Range("A1").PasteSpecial Paste:=xlPasteFormats
Rows("1:10").EntireRow.Hidden = True
ActiveSheet.Name = Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Sheets("Store Input").Range("J30").Value
'Save in CSV
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=xLocation & "Order Template\" & xJBName & xStrDate, FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
ActiveWorkbook.Close Savechanges:=True
'ThisWorkbook.Show = False
End With
'SendWorkBook
End Sub
To hide and and protect sheet and specific column
To hide and and protect sheet and column
Sub SetActive()
Worksheets("STORE INPUT").Activate
Worksheets("STORE INPUT").Range("U21").Activate
End Sub
Public Sub UnhideInput()
Worksheets("STORE INPUT").Activate
ActiveSheet.AutoFilterMode = False
Columns("G:Z").EntireColumn.Hidden = False
End Sub
Public Sub HideInput()
Worksheets("STORE INPUT").Activate
ActiveSheet.AutoFilterMode = False
Columns("G:Z").EntireColumn.Hidden = True
End Sub
Public Sub ProtectInput()
Worksheets("STORE INPUT").Activate
ActiveSheet.AutoFilterMode = False
ActiveSheet.Protect Password:="CENTRUM17"
End Sub
Public Sub UnProtectInput()
Worksheets("STORE INPUT").Activate
ActiveSheet.AutoFilterMode = False
ActiveSheet.Unprotect Password:="CENTRUM17"
End Sub
Public Sub GoToSWS()
Worksheets("STORE INPUT").Activate
Worksheets("STORE INPUT").Range("A36").Activate
End Sub
Sub Clear_All()
Range("K13:K300").Select
Selection.ClearContents
Range("N13:N300").Select
Selection.ClearContents
Range("R13:R300").Select
Selection.ClearContents
End Sub
Public Sub UnHideMOTRow()
ActiveWorkbook.Sheets("MASTER ORDER TEMPLATE").Activate
Rows("2:10").EntireRow.Hidden = False
Rows("11:12").EntireRow.Hidden = True
End Sub
Public Sub HideMOTRow()
ActiveWorkbook.Sheets("MASTER ORDER TEMPLATE").Activate
ActiveSheet.AutoFilterMode = False
Rows("2:10").EntireRow.Hidden = True
Rows("11:12").EntireRow.Hidden = False
End Sub
Public Sub UnHideMOTColumn()
ActiveWorkbook.Sheets("MASTER ORDER TEMPLATE").Activate
ActiveSheet.AutoFilterMode = False
Columns("W:AT").EntireColumn.Hidden = False
End Sub
Public Sub HideMOTColumn()
Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Worksheets("Master Order Template").Activate
ActiveSheet.AutoFilterMode = False
Columns("W:AT").EntireColumn.Hidden = True
End Sub
Public Sub ProtectMOT()
ActiveWorkbook.Sheets("MASTER ORDER TEMPLATE").Activate
ActiveSheet.Protect Password:="CENTRUM17"
' ActiveSheet.AutoFilterMode = True
End Sub
Public Sub UnProtectMOT()
ActiveWorkbook.Sheets("MASTER ORDER TEMPLATE").Activate
ActiveSheet.Unprotect Password:="CENTRUM17"
End Sub
Sub ViewMOTFiltered()
Worksheets("MASTER ORDER TEMPLATE").Activate
Worksheets("MASTER ORDER TEMPLATE").Range("A12").Activate
ActiveSheet.AutoFilterMode = False
ActiveSheet.Range("$A$12:$AP$300").AutoFilter Field:=24, Criteria1:=Array("Y", "NT"), Operator:=xlFilterValues
End Sub
Sub ViewMOT2()
Worksheets("MASTER ORDER TEMPLATE").Activate
Worksheets("MASTER ORDER TEMPLATE").Range("A12").Activate
End Sub
To attach active work book and send to outlook
To attach active work book and send to outlook
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim xStrDate As String
Dim xJBName As String
On Error GoTo ErrHandler
xStrDate = Format(Now, "mm-dd-yyyy")
xJBName = Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Sheets("Store Input").Range("B9").Value
' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.to = "celine.bautista@jollibee.com.ph"
.CC = ""
.BCC = ""
.Subject = "CENTRUM: Order Template test2"
.Body = "CENTRUM Order Template for " & xJBName & vbNewLine & "Date generated: " & xStrDate
.Attachments.Add Application.ActiveWorkbook.FullName
.Send
End With
' CLEAR.
Set objEmail = Nothing: Set objOutlook = Nothing
MsgBox "CENTRUM ORDER TEMPLATE SENT!"
Exit Sub
ErrHandler:
Set OutMail = Nothing
Set OutApp = Nothing
err.Clear
MsgBox "Please manually send your File!"
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim xStrDate As String
Dim xJBName As String
On Error GoTo ErrHandler
xStrDate = Format(Now, "mm-dd-yyyy")
xJBName = Workbooks("CENTRUM REPLENISHMENT TEMPLATE.xlsm").Sheets("Store Input").Range("B9").Value
' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.to = "celine.bautista@jollibee.com.ph"
.CC = ""
.BCC = ""
.Subject = "CENTRUM: Order Template test2"
.Body = "CENTRUM Order Template for " & xJBName & vbNewLine & "Date generated: " & xStrDate
.Attachments.Add Application.ActiveWorkbook.FullName
.Send
End With
' CLEAR.
Set objEmail = Nothing: Set objOutlook = Nothing
MsgBox "CENTRUM ORDER TEMPLATE SENT!"
Exit Sub
ErrHandler:
Set OutMail = Nothing
Set OutApp = Nothing
err.Clear
MsgBox "Please manually send your File!"
To export all sheet to PDF/To export as pdf active sheet
To export all sheet to PDF
Sub exportAllSheetsTopdf()
fName = ActiveWorkbook.FullName
If InStr(fName, ".") > 0 Then fName = Left(fName, InStrRev(fName, ".") - 1)
ActiveWorkbook.ExportAsFixedFormat xlTypePDF, fName & ".pdf", _
xlQualityStandard, , , , , True
End Sub
---------------------------------------------------------------------------
To export as pdf active sheet
Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Sub exportAllSheetsTopdf()
fName = ActiveWorkbook.FullName
If InStr(fName, ".") > 0 Then fName = Left(fName, InStrRev(fName, ".") - 1)
ActiveWorkbook.ExportAsFixedFormat xlTypePDF, fName & ".pdf", _
xlQualityStandard, , , , , True
End Sub
---------------------------------------------------------------------------
To export as pdf active sheet
Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
To delete specific sheet by name
To delete specific sheet by name
******changes the shName base on name of sheet
Sub Deletebyname()
'Updateby Extendoffice 20160930
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = "Sheet"
''ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
xName = "*" & shName & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
If xWs.Name Like xName Then
xWs.delete
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted" & cnt & "worksheets", vbInformation, "Kutools for Excel"
End Sub
******changes the shName base on name of sheet
Sub Deletebyname()
'Updateby Extendoffice 20160930
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = "Sheet"
''ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
xName = "*" & shName & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
If xWs.Name Like xName Then
xWs.delete
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted" & cnt & "worksheets", vbInformation, "Kutools for Excel"
End Sub
To copy whole sheets to another workbook
To copy whole sheets to another workbook
Sub GetSheets()
Dim path As String
path = Sheets("DO NOT DELETE").Range("e1")
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
Protect all worksheets and unprotect
Protect all worksheets and unprotect
Sub ProtectAll()
Dim wsheet As Worksheet
For Each wsheet In ActiveWorkbook.Worksheets
wsheet.Protect password:="123"
Next wsheet
End Sub
----------------------------------------------------------------------------
Sub DeProtectAll()
Dim wsheet As Worksheet
For Each wsheet In ActiveWorkbook.Worksheets
wsheet.Unprotect password:="123"
Next wsheet
End Sub
To delete pivot table
To delete pivot table
Sub DeleteAllPivotTables()
'PURPOSE: Delete all Pivot Tables in your Workbook
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim pvt As PivotTable
'Loop Through Each Pivot Table In Currently Viewed Workbook
For Each sht In ActiveWorkbook.Worksheets
For Each pvt In sht.PivotTables
pvt.TableRange2.Clear
Next pvt
Next sht
End Sub
-------------------------------------------------------------------------------
Sub DeleteSpecificPivotTablesMON()
Dim Wks As Worksheet
Dim PT As PivotTable
If ActiveWorkbook Is Nothing Then
MsgBox "There is no active workbook!", vbExclamation, "ERROR!"
Exit Sub
End If
For Each Wks In ActiveWorkbook.Worksheets
For Each PT In Wks.PivotTables
Select Case PT.Name
Case "PivotTable1"
PT.TableRange2.Clear
End Select
Next PT
Next Wks
End Sub
Sub DeleteAllPivotTables()
'PURPOSE: Delete all Pivot Tables in your Workbook
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim pvt As PivotTable
'Loop Through Each Pivot Table In Currently Viewed Workbook
For Each sht In ActiveWorkbook.Worksheets
For Each pvt In sht.PivotTables
pvt.TableRange2.Clear
Next pvt
Next sht
End Sub
-------------------------------------------------------------------------------
Sub DeleteSpecificPivotTablesMON()
Dim Wks As Worksheet
Dim PT As PivotTable
If ActiveWorkbook Is Nothing Then
MsgBox "There is no active workbook!", vbExclamation, "ERROR!"
Exit Sub
End If
For Each Wks In ActiveWorkbook.Worksheets
For Each PT In Wks.PivotTables
Select Case PT.Name
Case "PivotTable1"
PT.TableRange2.Clear
End Select
Next PT
Next Wks
End Sub
To remove blank cells only
To remove blank cells only
Sub RemoveBlankCells()
'PURPOSE: Deletes single cells that are blank located inside a designated range
'SOURCE: www.TheSpreadsheetGuru.com
Dim rng As Range
'Store blank cells inside a variable
On Error GoTo NoBlanksFound
Set rng = Range("A1:b10000").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
'Delete blank cells and shift upward
rng.Rows.Delete Shift:=xlShiftUp
Exit Sub
'ERROR HANLDER
NoBlanksFound:
MsgBox "No Blank cells were found"
End Sub
Sub RemoveBlankCells()
'PURPOSE: Deletes single cells that are blank located inside a designated range
'SOURCE: www.TheSpreadsheetGuru.com
Dim rng As Range
'Store blank cells inside a variable
On Error GoTo NoBlanksFound
Set rng = Range("A1:b10000").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
'Delete blank cells and shift upward
rng.Rows.Delete Shift:=xlShiftUp
Exit Sub
'ERROR HANLDER
NoBlanksFound:
MsgBox "No Blank cells were found"
End Sub
Another way to copy data from other workbook
Sub extracthourlysun()
Dim wbkWorkbook1 As Workbook
Dim wbkWorkbook2 As Workbook
Dim fileName As String
Dim Path As String
Path = Sheets("sheet2").Range("A1")
fileName = Dir(Path & "SUN-TC.xls")
'define paths and filenames
'open files
Set wbkWorkbook1 = ThisWorkbook '### changed this
Set wbkWorkbook2 = Workbooks.Open(Path & fileName)
'copy the values across
'### change the sheet and range to what you need
wbkWorkbook2.Worksheets("Sheet1").Range("A:J").Copy
'wbkWorkbook1.Worksheets("Summary").Select
wbkWorkbook1.Worksheets("SUN-TC").Range("A:J").PasteSpecial
Application.DisplayAlerts = False
'close the workbook
wbkWorkbook2.Close (True)
end sub
Another way to drag or fill ranges
Another way to drag or fill ranges
Sub drag()
Dim lastRow As Long
lastRow = Sheets("SUNPIV").Range("d" & Rows.Count).End(xlUp).row
Sheets("SUNPIV").Range("e2").AutoFill Destination:=Range("e2:e" & lastRow)
end sub
To Search specific a cell value and move to another column
To Search specific a cell value and move to another column
The specific value that is looking is the Time value that has time
The column b with specific value will be move to column a
Sub Findandcut()
Dim row As Long
For row = 2 To 100000
' Check if "save" appears in the value anywhere.
If Range("b" & row).Value Like "*Time*" Then
' Copy the value and then blank the source.
Range("A" & row).Value = Range("b" & row).Value
Range("B" & row).Value = ""
End If
Next
End Sub
Another way to copy data and paste within workbook
Another way to copy data and paste within workbook
Worksheets("SUNRAW").Range("A1:C10000").Copy
Worksheets("SUNPIV").Range("A26").PasteSpecial Paste:=xlPasteValues
Worksheets("SUNRAW").Range("D1:D10000").Copy
Worksheets("SUNPIV").Range("E26").PasteSpecial Paste:=xlPasteValues
Worksheets("SUNPIV").Range("h2:h10000").Copy
Worksheets("SUNPIV").Range("d26").PasteSpecial Paste:=xlPasteValues
Worksheets("SUNRAW").Range("A1:C10000").Copy
Worksheets("SUNPIV").Range("A26").PasteSpecial Paste:=xlPasteValues
Worksheets("SUNRAW").Range("D1:D10000").Copy
Worksheets("SUNPIV").Range("E26").PasteSpecial Paste:=xlPasteValues
Worksheets("SUNPIV").Range("h2:h10000").Copy
Worksheets("SUNPIV").Range("d26").PasteSpecial Paste:=xlPasteValues
If cell value changes and equal to your specific choice a macro will run
If cell value changes and equal to your specific choice a macro will run
Sub worksheet_change(ByVal target As Range)
Set target = Range("I6")
If target.Value = "1 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t1
End If
End sub
------------------------------------------------------------------------------------
Sub worksheet_change(ByVal target As Range)
Set target = Range("I6")
Call sbUnProtectSheet
If target.Value = "1 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t1
End If
If target.Value = "2 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t2
Rows("54:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "3 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t3
Rows("52:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "4 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t4
Rows("50:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "5 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t5
Rows("48:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "6 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t6
Rows("46:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "7 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t7
Rows("44:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "8 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t8
Rows("42:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "9 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t9
Rows("40:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "10 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t10
Rows("38:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "11 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t11
Rows("36:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "12 PM" Then
Rows("7:55").EntireRow.Hidden = False
Call t12
Rows("34:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
Call sbProtectSheet
End Sub
Sub sbProtectSheet()
Sheets("PCS").Protect "rsadmin", True, True
End Sub
Sub sbUnProtectSheet()
Sheets("PCS").Unprotect "rsadmin"
End Sub
Sub worksheet_change(ByVal target As Range)
Set target = Range("I6")
If target.Value = "1 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t1
End If
End sub
------------------------------------------------------------------------------------
Sub worksheet_change(ByVal target As Range)
Set target = Range("I6")
Call sbUnProtectSheet
If target.Value = "1 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t1
End If
If target.Value = "2 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t2
Rows("54:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "3 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t3
Rows("52:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "4 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t4
Rows("50:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "5 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t5
Rows("48:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "6 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t6
Rows("46:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "7 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t7
Rows("44:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "8 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t8
Rows("42:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "9 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t9
Rows("40:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "10 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t10
Rows("38:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "11 AM" Then
Rows("7:55").EntireRow.Hidden = False
Call t11
Rows("36:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
If target.Value = "12 PM" Then
Rows("7:55").EntireRow.Hidden = False
Call t12
Rows("34:55").EntireRow.Hidden = True
Rows("57:65536").EntireRow.Hidden = True
End If
Call sbProtectSheet
End Sub
Sub sbProtectSheet()
Sheets("PCS").Protect "rsadmin", True, True
End Sub
Sub sbUnProtectSheet()
Sheets("PCS").Unprotect "rsadmin"
End Sub
To remove row base on 1st cell ranges that is blank
To remove row base on 1st cell ranges that is blank
Sub RemoveEmptyRows()
On Error Resume Next
Range("G1:G100").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sub RemoveEmptyRows()
On Error Resume Next
Range("G1:G100").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
To copy data from other workbook until the last data and paste to active workbook
To copy data from other workbook until the last data and paste to active workbook
Sub CopyData()
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
For Each wB In Application.Workbooks
If Left(wB.Name, 21) = "Book1" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then '<~~ check if you actually found the needed workbook
Set wb2 = ThisWorkbook
With Wb1.Sheets("Sheet1")
Set rngToCopy = .Range("A2:AM2", .Cells(.Rows.Count, "A").End(xlUp))
End With
wb2.Sheets("Sheet2").Range("B5:AN5").Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
End If
End Sub
Sub CopyData()
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
For Each wB In Application.Workbooks
If Left(wB.Name, 21) = "Book1" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then '<~~ check if you actually found the needed workbook
Set wb2 = ThisWorkbook
With Wb1.Sheets("Sheet1")
Set rngToCopy = .Range("A2:AM2", .Cells(.Rows.Count, "A").End(xlUp))
End With
wb2.Sheets("Sheet2").Range("B5:AN5").Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
End If
End Sub
To delete first row on excel depending how many times
To delete first row on excel depending how many times
Sub sbVBS_To_Delete_EntireRow_For_Loop()
Dim iCntr
For iCntr = 1 To 12 Step 1
Rows(1).EntireRow.Delete
Next
End Sub
To repeat codes a number of times for next
To repeat codes a number of times
Sub acc()
Dim i As Long
Dim a As String
a = Sheets("Sheet1").Range("q12").Value
For i = 1 To a
Call accumulator
Debug.Print i
Next i
End Sub
Sub acc()
Dim i As Long
Dim a As String
a = Sheets("Sheet1").Range("q12").Value
For i = 1 To a
Call accumulator
Debug.Print i
Next i
End Sub
To copy data to another workbook and paste to another workbook.
To copy data to another workbook and paste to another workbook.
Sub extractstore1()
Dim wbkWorkbook1 As Workbook
Dim wbkWorkbook2 As Workbook
Dim fileName As String
Dim Path As String
Dim path2 As String
Path = Sheets("Input Sheet").Range("i21")
path2 = Sheets("Input Sheet").Range("d11")
fileName = Dir(Path & path2 & ".CSV*")
'define paths and filenames
'open files
Set wbkWorkbook1 = ThisWorkbook '### changed this
Set wbkWorkbook2 = Workbooks.Open(Path & fileName)
'copy the values across
'### change the sheet and range to what you need
wbkWorkbook2.Worksheets("Sheet1").Range("A:DZ").Copy
'wbkWorkbook1.Worksheets("Summary").Select
wbkWorkbook1.Worksheets("Store 1").Range("A:DZ").PasteSpecial
Application.DisplayAlerts = False
wbkWorkbook2.Close (True)
End Sub
Sub extractstore1()
Dim wbkWorkbook1 As Workbook
Dim wbkWorkbook2 As Workbook
Dim fileName As String
Dim Path As String
Dim path2 As String
Path = Sheets("Input Sheet").Range("i21")
path2 = Sheets("Input Sheet").Range("d11")
fileName = Dir(Path & path2 & ".CSV*")
'define paths and filenames
'open files
Set wbkWorkbook1 = ThisWorkbook '### changed this
Set wbkWorkbook2 = Workbooks.Open(Path & fileName)
'copy the values across
'### change the sheet and range to what you need
wbkWorkbook2.Worksheets("Sheet1").Range("A:DZ").Copy
'wbkWorkbook1.Worksheets("Summary").Select
wbkWorkbook1.Worksheets("Store 1").Range("A:DZ").PasteSpecial
Application.DisplayAlerts = False
wbkWorkbook2.Close (True)
End Sub
Replace Blank Cells with Zeros
Replace Blank Cells with Zeros
For data where you have blank cells, you can add zeros in all
those cells. It makes easier to use formula and use those cells in further
calculations.
Sub replaceBlankWithZero()
Dim rngAs Range
Selection.Value= Selection.Value
For Each rngIn Selection
If rng= "" Or rng= " " Then
rng.Value= "0"
Else
End If
Next rng
End Sub
Convert Roman Numbers into Arabic Numbers
Convert Roman Numbers into Arabic Numbers
Sometimes it’s really hard to understand Roman numbers as serial
numbers. This code will help you to convert roman numbers into arabic numbers.
Sub convertToNumbers()
Dim rng As Range
Selection.Value= Selection.Value
For Each rng In Selection
If Not WorksheetFunction.IsNonText(rng) Then
rng.Value= WorksheetFunction.Arabic(rng)
End If
Next rng
End Sub
Calculate the Cube Root
Calculate the Cube Root
To calculate cube root without applying a formula you can use
this code. It will simply check all the selected cells and convert numbers to
their cube root.
Sub getCubeRoot()
Dim rng As Range
Dimi As Integer
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng ^ (1 / 3)
Else
End If
Nextrng
End Sub
Saturday, April 20, 2019
Add a Number in all the Numbers
Add a Number in all the Numbers
Just like multiplying you can also add a number into a set of
numbers.
Sub addNumber()
Dim rngAs Range
DimiAs Integer
i= InputBox("Enter number to multiple", "Input
Required")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value= rng+ i
Else
End If
Next rng
End Sub
Multiply all the Values by a Number
Multiply all the Values by a Number
Let’s you have a list of numbers and you want to multiply all
the number with a particular. Just use this code.
Select that range of cells and run this code. It will first ask
you for the number with whom you want to multiple and then instantly multiply
all the numbers with it.
Sub multiplyWithNumber()
Dim rng As Range
Dim c As Integer c = InputBox("Enter number to
multiple", "Input Required")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng * c
Else
End If
Next rng
End Sub
Remove the Apostrophe from a Number/Remove Decimals from Numbers
Remove the Apostrophe from a Number
If you have numeric data where you have an apostrophe before
each number, you run this code to remove it.
Sub removeApostrophes()
Selection.Value = Selection.Value
End Sub
Remove Decimals from Numbers
This code will simply help you to remove all the decimals from
the numbers from the selected range.
Sub removeDecimals()
Dim lnumber As Double
Dim lResult As Long
Dim rng As Range
For Each rng In Selection
rng.Value= Int(rng)
rng.NumberFormat= "0"
Next rng
End Sub
Word Count from Entire Worksheet
Word Count from Entire Worksheet
It can help you to count all the words from a worksheet.
Sub Word_Count_Worksheet()
Dim WordCnt As Long
Dim rng As Range
Dim S As String
Dim N As Long
For Each rng In ActiveSheet.UsedRange.Cells
S = Application.WorksheetFunction.Trim(rng.Text)
N = 0
If S <> vbNullString Then
N = Len(S) - Len(Replace(S, " ", "")) + 1
End If
WordCnt = WordCnt + N
Next rng
MsgBox "There are total " & Format(WordCnt,
"#,##0") & " words in the active worksheet"
End Sub
Remove a Character from Selection find replace
Remove a Character from Selection
To remove a particular character from a selected cell you can
use this code. It will show you an input box to enter the character you want to
remove.
Find and replace
Sub removeChar()
Dim Rng As Range
Dim rc As String
rc = InputBox("Character(s) to Replace", "Enter
Value")
For Each Rng In Selection
Selection.Replace What:=rc, Replacement:=""
Next
End Sub
Convert to Sentence Case/End Sub Convert to Proper Case/Convert to Lower Case/Convert to Upper Case
Convert to Upper Case
Select the cells and run this code. It will check each and every
cell of selected range and then convert it into upper case text.
Sub convertUpperCase()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value = UCase(Rng)
End If
Next
End Sub
Convert to Lower Case
This code will help you to convert selected text into lower case
text. Just select a range of cells where you have text and run this code.
If a cell has a number or any value other than text that value will remain
same.
Sub convertLowerCase()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value= LCase(Rng)
End If
Next
End Sub
Convert to Proper Case
And, this code will convert selected text into the proper case
where you have the first letter in capital and rest in small.
Sub convertProperCase()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value= WorksheetFunction.Proper(Rng.Value)
End If
Next
End Sub
Convert to Sentence Case
In text case, you have
the first letter of the first word in capital and rest all in words in small
for a single sentence. And, this code will help you convert normal text
into sentence
case.
Sub convertTextCase()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value= UCase(Left(Rng, 1)) & LCase(Right(Rng, Len(Rng)
-1))
End If
Next rng
End Sub
Subscribe to:
Posts (Atom)