About Me
Com tecnologia do Blogger.
Seguidores
Estatisticas
2006-03-19
VBA: Sequenciar numeração
7:27 da tarde |
Publicada por
JRod - PORTUGAL |
Editar mensagem
Se pretendermos que uma determinada célula sequencie sempre que quisermos abrir um workbook, podemos utilizar o seguinte código de McGimpsey, com a adaptação no código de abertura do workbook, uma vez que se incluiu no número sequencial o ano, no formato "nn/aa", com a porção de código & "/" & Right(Date, 2)
O código da Função NextSeqNumber():
Public Function NextSeqNumber(Optional sFileName As String, Optional nSeqNumber As Long = -1) As Long
Const sDEFAULT_PATH As String = "C:\GABINETE"
Const sDEFAULT_FNAME As String = "defaultseq.txt"
Dim nFileNumber As Long
nFileNumber = FreeFile
If sFileName = "" Then sFileName = sDEFAULT_FNAME
If InStr(sFileName, Application.PathSeparator) = 0 Then _
sFileName = sDEFAULT_PATH & Application.PathSeparator & sFileName
If nSeqNumber = -1& Then
If Dir(sFileName) <> "" Then
Open sFileName For Input As nFileNumber
Input #nFileNumber, nSeqNumber
nSeqNumber = nSeqNumber + 1&
Close nFileNumber
Else
nSeqNumber = 1&
End If
End If
On Error GoTo PathError
Open sFileName For Output As nFileNumber
On Error GoTo 0
Print #nFileNumber, nSeqNumber
Close nFileNumber
NextSeqNumber = nSeqNumber
Exit Function
PathError:
NextSeqNumber = -1&
End Function
NOTA:
sDEFAULT_PATH e sDEFAULT_FNAME indicados a título de exemplo, podendo ser, como óbvio, alterados.
NOTA:
A célula onde recai o valor sequencial, deve ser formatada como texto.
O Código de abertura do Workbook:
Private Sub Workbook_Open()
ThisWorkbook.Sheets(1).Range("B2").Value = NextSeqNumber & "/" & Right(Date, 2)
End Sub
O resultado:
O código da Função NextSeqNumber():
Public Function NextSeqNumber(Optional sFileName As String, Optional nSeqNumber As Long = -1) As Long
Const sDEFAULT_PATH As String = "C:\GABINETE"
Const sDEFAULT_FNAME As String = "defaultseq.txt"
Dim nFileNumber As Long
nFileNumber = FreeFile
If sFileName = "" Then sFileName = sDEFAULT_FNAME
If InStr(sFileName, Application.PathSeparator) = 0 Then _
sFileName = sDEFAULT_PATH & Application.PathSeparator & sFileName
If nSeqNumber = -1& Then
If Dir(sFileName) <> "" Then
Open sFileName For Input As nFileNumber
Input #nFileNumber, nSeqNumber
nSeqNumber = nSeqNumber + 1&
Close nFileNumber
Else
nSeqNumber = 1&
End If
End If
On Error GoTo PathError
Open sFileName For Output As nFileNumber
On Error GoTo 0
Print #nFileNumber, nSeqNumber
Close nFileNumber
NextSeqNumber = nSeqNumber
Exit Function
PathError:
NextSeqNumber = -1&
End Function
NOTA:
sDEFAULT_PATH e sDEFAULT_FNAME indicados a título de exemplo, podendo ser, como óbvio, alterados.
NOTA:
A célula onde recai o valor sequencial, deve ser formatada como texto.
O Código de abertura do Workbook:
Private Sub Workbook_Open()
ThisWorkbook.Sheets(1).Range("B2").Value = NextSeqNumber & "/" & Right(Date, 2)
End Sub
O resultado:
2006-03-04
VBA: Userform e TextBox
5:20 da tarde |
Publicada por
JRod - PORTUGAL |
Editar mensagem
Por vezes, podemos ter a necessidade e utilizar, num Userform, um TextBox com comprimento fixo e com Multiline e WordWrap. Vejamos o exemplo:
Quando se inicia a escrita, a altura do TextBox aumenta automaticamente até à altura previamente definida:
Grava para a célula A1:
Para invocar o Userform que contem o TextBox, criamos um CommandButton na grelha:
O Código para o Comando:
Private Sub CommandButton1_Click()
FrmTeste.Show
End Sub
Os códigos em VBA:
Private Sub TextBox1_Change()
TextBox1.Width = 150
TextBox1.MultiLine = True
TextBox1.WordWrap = True
TextBox1.AutoSize = False
With Me.TextBox1
.Height = 80
End With
End Sub
Private Sub CommandButton1_Click()
Range("A1") = TextBox1.Value
End Sub
Quando se inicia a escrita, a altura do TextBox aumenta automaticamente até à altura previamente definida:
Grava para a célula A1:
Para invocar o Userform que contem o TextBox, criamos um CommandButton na grelha:
O Código para o Comando:
Private Sub CommandButton1_Click()
FrmTeste.Show
End Sub
Os códigos em VBA:
Private Sub TextBox1_Change()
TextBox1.Width = 150
TextBox1.MultiLine = True
TextBox1.WordWrap = True
TextBox1.AutoSize = False
With Me.TextBox1
.Height = 80
End With
End Sub
Private Sub CommandButton1_Click()
Range("A1") = TextBox1.Value
End Sub
Subscrever:
Mensagens (Atom)