Private Sub Print1_Click()
Application.Dialogs(xlDialogPrinterSetup).Show
Set MyRange = Range("B1:E5")
iNumCopies = Range("J1").Value
If iNumCopies < 1 Then iNumCopies = 1
MyRange.PrintOut Copies:=iNumCopies
End SubSub Five_Year()
Sheets("Raw5").Cells.ClearContents
Dim Stock As String
Dim xConnect As Object
ST = Sheets("Grading Sheet").Range("B2") ' ticker symbol of stock
SD = (Sheets("Grading Sheet").Range("C11") - DateValue("January 1, 1970")) * 86400 'today - 365*5
ED = (Sheets("Grading Sheet").Range("C12") - DateValue("January 1, 1970")) * 86400 'todays date
'Retrieve 5 Yr Data
With Sheets("Raw5").QueryTables.Add(Connection:= _
"finance.yahoo.com/quote/" & ST & "/history?period1=" & SD & "&period2=" & ED & "&interval=1mo&filter=history&frequency=1wk" _ 'ignore faulty link
, Destination:=Sheets("Raw5").Range("$A$1"))
.Name = "5Yr"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End SubPrivate Sub deletecancel_Click()
Dim myRange As Range
'declare object variable used to iterate through the elements of the cell range
Dim iCell As Range
'declare variable to hold value you search for
Dim myValue As Integer
Dim myValue1 As Integer
Dim myValue2 As Integer
Dim myValue3 As Integer
Dim myValue4 As Integer
Dim Lastrow5 As Integer
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Set myRange = Range("B2:B" & LastRow)
'set value to search for
myValue = 81
myValue1 = 82
myValue2 = 83
myValue3 = 84
myValue4 = 85
myValue5 = 86
'loop through each cell (iCell) of the cell range (myRange)
Application.EnableEvents = False
For Each iCell In myRange
'test if value i. If condition is met, clear cell
If iCell.Value = myValue Or iCell.Value = myValue2 Or iCell.Value = myValue3 Or iCell.Value = myValue4 Or iCell.Value = myValue5 Then
iCell.Offset(, 3).Value = ..
End If
Next iCell
Application.EnableEvents = True
End Sub
MKDir Location
Set Location = "& Me.TxtTNo & " & " & Me.txtcustname.Value & " & " & Me.txtoptsurfacesn & "
nwb.SaveAs Filename:="C:\Users\Chris' Laptop\Desktop\Location\" & Me.TxtTNo & " " & Me.txtcustname.Value & " " & Me.txtbbsn & " " & Me.txtoptsurfacesn & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled'ThisWorkbook
Private Sub Workbook_Open()
UserForm1.Show (vbModeless)
End Sub'UserForm1
Dim EnableEvents As Boolean
Private Sub ComboBox1_Change()
If EnableEvents Then
MsgBox "Running change event", vbInformation, "Test"
givenVal = ComboBox1.Value
EnableEvents = False
MsgBox "Trying to delete the second worksheet", vbInformation, "Test"
ThisWorkbook.Worksheets(2).Delete
EnableEvents = True
End If
End Sub
Private Sub UserForm_Initialize()
EnableEvents = False
UserForm1.ComboBox1.RowSource = "[TestComboBox.xlsm]Sheet1!$B$1:$B$4"
UserForm1.ComboBox1.ListIndex = 3
EnableEvents = True
End SubOption Explicit
'Criação das variáveis globais para utilização em todos os módulos
Global str_Conexao 'As String
Global ado_Conexao 'As ADODB.Connection
Global str_Versao 'As String
Sub Conectar_Excel()
Dim Caminho As String
Dim Arquivo As String
Caminho = Planilha2.Range("c4")
Arquivo = Planilha2.Range("c6")
'Define string de Conexão
str_Conexao = _
"Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
"DSN=TESTE_SQL;DBQ=" & Caminho & Arquivo & ";" _
& "ReadOnly=0;DefaultDir=" & Caminho & ";" _
& "DriverId=1046;FIL=excel 12.0;MaxBufferSize=2048;PageTimeout=5;"
'Seta ADODB
Set ado_Conexao = CreateObject("ADODB.Connection")
'Abre Conexão
ado_Conexao.Open str_Conexao
End Sub
Private Sub CommandButton1_Click()
listar_dados
End Sub
Sub listar_dados()
'Chama rotina de Conexão
Call Conectar_Excel
'Seta RecordSet
Set rs_Consulta = CreateObject("ADODB.Recordset")
'Define da Query
str_consulta = Planilha1.Range("G5")
'Abre Recordset
rs_Consulta.Open str_consulta, ado_Conexao
'Limpa o Relatório
limpar
'Cola Recordset na planilha
Planilha1.Range("b13").CopyFromRecordset rs_Consulta
'FechaConexão
rs_Consulta.Close
Set rs_Consulta = Nothing
End Sub
Sub limpar()
Planilha1.Range("b12:aa5000").ClearContents
End SubPublic Function tau(n As Double) As Double
Dim k As Double
tau = 0
For k = 1 To n
If n Mod k = 0 Then tau = tau + 1
Next k
End FunctionSub filter_test()
Dim rang As Range
Set wt = ThisWorkbook.Sheets("Sheet1")
wt.UsedRange.AutoFilter field:=21, Criteria1:="<>0", Operator:=xlFilterValues
Set rang = wt.UsedRange.Offset(1, 0)
Set rang = rang.Resize(rang.Rows.Count - 1)
Set rang = rang.SpecialCells(xlCellTypeVisible)
rang.Copy ThisWorkbook.Sheets("Sheet2").Range("A1")
End SubSub Sort_And_Match()
Application.ScreenUpdating = False
counter = 0
SortMultipleColumns
Matching
If counter = 1 Then
SortMultipleColumns
Matching
End If
Application.ScreenUpdating = True
End SubSub Matching()
Application.ScreenUpdating = False
Numrows = Range("A1", Range("A1").End(xlDown)).Rows.Count
Set Rng = Range("A2:A" & Numrows)
For Each Cell In Rng
RowNumber = Cell.Row
RowNumberPlus = RowNumber + 1
If Range("B" & RowNumber) = -Range("B" & RowNumberPlus) Then
If Range("A" & RowNumber) = Range("A" & RowNumberPlus) Then
Range("A" & RowNumber).Resize(2).EntireRow.Delete
counter = 1
End If
End If
Next Cell
End SubSub SortMultipleColumns()
Numrows = Range("A1", Range("A1").End(xlDown)).Rows.Count
Set Rng = Range("A2:B" & Numrows)
Columns("C").EntireColumn.Insert
For Each Cell In Rng
RowNumber = Cell.Row
Range("C" & RowNumber).Value = Abs(Range("B" & RowNumber))
Next Cell
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SortFields.Add Key:=Range("C1"), Order:=xlAscending
.SetRange Range("A1:C" & Numrows)
.Header = xlYes
.Apply
Range("C" & RowNumber).EntireColumn.Delete
End With
End Sub