Ir para conteúdo

Arquivado

Este tópico foi arquivado e está fechado para novas respostas.

DinhoPHP

Inserção duplicada

Recommended Posts

Bom dia!

 

Estou utilizando esta programação para cadastrar nomes de PCs e partir desta lista checar se o nome da máquina consta nela para exibir uma planilha e esconder a mesma, só que está havendo um cadastramento duplicados e não sei porque. Isso não pode ocorrer.

 

Obs: Não programo macros, e sim para web como: JAVA, PHP, HTML5 e etc.i

Compartilhar este post


Link para o post
Compartilhar em outros sites
Private Sub btnok_Click()

'verifica se tudo foi preenchido

If Me.txtnome = "" Then

MsgBox "Insira o nome computador", vbExclamation, "Erro!"

Exit Sub

Me.txtnome.SetFocus

'ElseIf Me.txtcargo = "" Then

'MsgBox "Insira cargo / setor!", vbExclamation, "Erro!"

'Exit Sub

'Me.txtcargo.SetFocus

'ElseIf Len(Me.txtdata) < Me.txtdata.MaxLength Then

'MsgBox "Insira data no formato dd/mm/aaaa!", _

' vbExclamation, "Erro!"

'Exit Sub

'Me.txtdata.SetFocus

End If


'solicita autorização

If MsgBox("Deseja inserir estes dados?", vbOKCancel + vbQuestion, _

"Atenção!") = vbCancel Then Exit Sub


'desabilita atualização de tela

Application.ScreenUpdating = False


'LANÇA NA ABA GERAL


'desprotege a planilha

ActiveSheet.Unprotect

'exibe todas as linhas

ActiveSheet.Rows.Hidden = False

'define última linha da lista

Dim lin As Integer

lin = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

'lança o nome na última linha

Cells(lin, 1) = Me.txtnome

Cells(lin, 1).HorizontalAlignment = xlLeft

'Cells(lin, 2) = Me.txtcargo

'Cells(lin, 2).HorizontalAlignment = xlLeft

'Cells(lin, 3) = Format(Me.txtdata, "mm/dd/yyyy")

'Cells(lin, 3).HorizontalAlignment = xlCenter

'desenha bordas na linha preenchida

Range(Cells(lin, 1), _

Cells(lin, 1)).Borders.LineStyle = xlContinuous

'organiza em ordem crescente (pela coluna A)

With ActiveSheet

.Sort.SortFields.Clear

.Sort.SortFields.Add Key:=Range("A3"), _

SortOn:=xlSortOnValues, Order:=xlAscending, _

DataOption:=xlSortNormal

End With

With ActiveSheet.Sort

.SetRange Range("A3:C" & lin)

.Header = xlNo

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

'oculta linhas vazias

Range(Cells(lin + 1, 1), Cells(Rows.Count, 1)).EntireRow.Hidden = True

Range("A1").Select

'protege a planilha

ActiveSheet.Protect


'LANÇA NA ABA ESPECÍFICA


'Sheets(Format(Month(Me.txtdata), "00")).Select

'desprotege a planilha

ActiveSheet.Unprotect

'exibe todas as linhas

ActiveSheet.Rows.Hidden = False

'define última linha da lista

Dim lin2 As Integer

lin2 = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

'lança o nome na última linha

Cells(lin2, 1) = Me.txtnome

Cells(lin2, 1).HorizontalAlignment = xlLeft

'Cells(lin2, 2) = Me.txtcargo

'Cells(lin2, 2).HorizontalAlignment = xlLeft

'Cells(lin2, 3) = Format(Day(Me.txtdata), "00")

'Cells(lin2, 3).HorizontalAlignment = xlCenter

'desenha bordas na linha preenchida

Range(Cells(lin2, 1), _

Cells(lin2, 3)).Borders.LineStyle = xlContinuous

'organiza em ordem crescente (pela coluna A)

With ActiveSheet

.Sort.SortFields.Clear

.Sort.SortFields.Add Key:=Range("C3"), _

SortOn:=xlSortOnValues, Order:=xlAscending, _

DataOption:=xlSortNormal

End With

With ActiveSheet.Sort

.SetRange Range("A3:C" & lin2)

.Header = xlNo

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

'oculta linhas vazias

Range(Cells(lin2 + 1, 1), Cells(Rows.Count, 1)).EntireRow.Hidden = True

Range("A1").Select

'protege a planilha

ActiveSheet.Protect


'VOLTA NA ABA GERAL

Sheets("geral").Select


'habilita atualização de tela

Application.ScreenUpdating = True


'limpa o formulário

Me.txtnome = ""

'Me.txtcargo = ""

'Me.txtdata = ""

Me.txtnome.SetFocus


End Sub


Private Sub btnlimpar_Click()

Me.txtnome = ""

'Me.txtcargo = ""

'Me.txtdata = ""

Me.txtnome.SetFocus

End Sub


Private Sub btnsair_Click()

Unload Me

End Sub


Private Sub Label1_Click()


End Sub


Private Sub txtnome_Change()

Me.txtnome.MaxLength = 50

Me.txtnome = UCase(Me.txtnome)

End Sub


Private Sub txtcargo_Change()

'Me.txtcargo.MaxLength = 30

'Me.txtcargo = UCase(Me.txtcargo)

End Sub


Private Sub txtdata_Change()

'txtdata.MaxLength = 10

Select Case KeyAscii

Case 8, 48 To 57 ' backspace e numéricos

Case Else ' o resto é travado

KeyAscii = 0

End Select


If KeyAscii = vbKeyReturn Or KeyAscii = vbKeyBack Then Exit Sub


If KeyAscii < vbKey0 Or KeyAscii > vbKey9 Then

KeyAscii = 0

End If


'If Len(txtdata) = 2 Then

' txtdata.Text = txtdata.Text & "/"

' SendKeys "{End}", False

'ElseIf Len(txtdata) = 5 Then

' txtdata.Text = txtdata.Text & "/"

' SendKeys "{End}", False

'End If


End Sub

Compartilhar este post


Link para o post
Compartilhar em outros sites

por Reinaldo » Seg Jan 04, 2016 11:27 am

O trecho 'LANÇA NA ABA GERAL e 'LANÇA NA ABA ESPECÍFICA não se movimentam entre as abas do arquivo, lançam dados SEMPRE na aba ativa (activesheet).
Aparentemente o arquivo está posicionado na Aba Geral no inicio do "Lançamento de Dados", como a linha :
'Sheets(Format(Month(Me.txtdata), "00")).Select foi comentada/inibida, os dados à partir dessa linha são inseridos na mesma aba; é preciso determinar/selecionar a aba especifica, ou elininar essas linhas da rotina

Compartilhar este post


Link para o post
Compartilhar em outros sites

  • Conteúdo Similar

    • Por Luiz Henrique
      Olá,

      Fiz um sistema de busca para preços, e a mesma será realizada em tags, porém como o conteúdo é estático e não há necessidade de segurança é gerado um json para não precisar consultar o DB toda hora, segue parte do código:
       
      ... foreach ($data as $key => $value) { if (strpos($value->$alvo, $valor) !== false) { $array[] = [ ... ]; } } ... O código é simples, é um foreach para percorrer o json e se encontrar a busca,  cria um array com as informações, ok.
       
      Mas queria uma busca com no mysqli,  algo semelhante ao %LIKE%, existe alguma forma de eu fazer isso no php?
      Porque da forma que fiz só funciona se digitar a palavra inteira na busca.
       
      Ex:
      Quero buscar "computador", não consigo digitar as 4 primeiras letras da busca: "comp", precisa ser "computador".
       
      Obrigado.
    • Por Pedro_Gomes
      Sou estudante de Programação e nunca tinha usado VBA e tenho de entregar um trabalho, mas nunca tive formação nesta linguagem, e estou a ter problemas  no programa na parte de Pesquisar registros com filtros, já tentei ao máximo fazer seguindo tutoriais na internet, até que uma pessoua me ajudou e mandou-me codia e disse para fazer um passos só que eu nao sei seguir esses passos.
       Fico muito agradecido se alguém me conseguir ajudar.
         
      O que a pessoa me indicou:
      " Para testar o código coloque um filtro na planilha Dados no range A1:L1 e crie uma planilha com o nome de Auxiliar. Cole o código no formulário Pesquisar. "
       
      Option Explicit Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Call Filtro(TextBox1.Text, ComboBox1.Text) End Sub Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Call Filtro(TextBox2.Text, ComboBox2.Text) End Sub Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Call Filtro(TextBox3.Text, ComboBox3.Text) End Sub Private Sub UserForm_Initialize() ComboBox1.RowSource = "Relatório!A1:A12" ComboBox2.RowSource = "Relatório!A1:A12" ComboBox3.RowSource = "Relatório!A1:A12" End Sub Sub Filtro(ByVal Pesquisa As String, Campo As String) Dim Coluna As Integer Dim Area As Range Set Area = ThisWorkbook.Sheets("Dados").[A1:L1] Coluna = WorksheetFunction.Match(Campo, Area, 0) If Pesquisa <> "" Then If IsNumeric(Pesquisa) = False Then Pesquisa = "*" & Pesquisa & "*" Call Area.AutoFilter(Field:=Coluna, Criteria1:=Pesquisa) Call CopiaTabela Call PreencheListBox End If End Sub Sub CopiaTabela() ThisWorkbook.Sheets("Auxiliar").[A:L].Clear ThisWorkbook.Sheets("Dados").[A1].CurrentRegion.Copy ThisWorkbook.Sheets("Auxiliar").[A1].PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub Sub PreencheListBox() Dim Area As Range Set Area = ThisWorkbook.Sheets("Auxiliar").[A1].CurrentRegion ListBox1.ColumnCount = Area.Columns.Count ListBox1.ColumnHeads = True ListBox1.RowSource = "Auxiliar!" & Area.Offset(1).Address End Sub Link do Programa: 
      https://drive.google.com/file/d/1ucJVL5Ijg0IcDqaFzoJi8aiMPb0NCbjI/view?usp=sharing
    • Por gereiz
      Bom dia a todos. Adaptei um código para renomear vários arquivo com vba, que realiza a seguinte função:
       
      1) Eu seleiono a pasta,
      2) O VBA abre o PDF (Nota fiscal) , extrai a informação do texto e com a razão social fecha o pdf e renomeia ele com o nome extraido.
       
      O problema é que após renomear o primeiro arquivo corretamente a execução do código trava, e é necessário finalizar o processo.
      Segue abaixo o código.
      Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) Public Function ListaArquivos(ByVal Caminho As String) As String()          'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime     Dim FSO As New FileSystemObject     Dim result() As String     Dim Pasta As Folder     Dim Arquivo As File     Dim Indice As Long         ReDim result(0) As String     If FSO.FolderExists(Caminho) Then         Set Pasta = FSO.GetFolder(Caminho)           For Each Arquivo In Pasta.Files             Indice = IIf(result(0) = "", 0, Indice + 1)             ReDim Preserve result(Indice) As String             result(Indice) = Arquivo.Name         Next     End If       ListaArquivos = result ErrHandler:     Set FSO = Nothing     Set Pasta = Nothing     Set Arquivo = Nothing End Function Private Sub selecionar_pasta()  Dim box As Folder  Dim arquivos() As String  Dim lCtr As Long  Dim AdobeApp As String  Dim StartAdobe  Dim Arquivo As String  Dim NomeAntigo As String  Dim NomeNovo As String        On Error Resume Next      linha = 1      ultima_linha = Sheets("teste").Cells(Rows.Count, 1).End(xlUp).Row                  With Application.FileDialog(msoFileDialogFolderPicker)             .Title = "Buscar pasta"             .InitialFileName = ThisWorkbook.Path             .Show             .AllowMultiSelect = False             Pasta = .SelectedItems(1)         End With         TextBox1 = box          arquivos = ListaArquivos(Pasta)     Sleep 1000     For lCtr = 0 To UBound(arquivos)       Debug.Print arquivos(lCtr)         'Inserir código aqui'                  'Cells(linha, 1).Value = arquivos(lCtr)         'linha = (linha + 1)         'Sleep 500                                 pdf = arquivos(lCtr)                    AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"                      Sleep 2000                                          For Each pdf In Pasta                                 Adobefile = Pasta & "\" & pdf                    StartAdobe = Shell("" & AdobeApp & " " & """" & Adobefile & """" & "", 1)                              Sleep 2000                                         Application.SendKeys ("^a")             Application.SendKeys ("^c")              Sleep 2000                                    Dim KillPdf As String            KillPdf = "TASKKILL /F /IM AcroRd32.exe"            Shell KillPdf, vbHide                                               AppActivate Application.Caption                                            Sheets("teste").Range("A1").Activate             SendKeys ("^v")                                   DoEvents                                                                     Dim Razao As String             Razao = Sheets("teste").Range("A17").Value             pontos = InStr(1, Razao, ":")             qtdeLetras = Len(Razao)             Nome = Right(Razao, qtdeLetras - pontos)             Sheets("teste").Range("C1").Value = Nome                                                                   Do While Not IsEmpty(Range("C1"))                                              NomeAntigo = Pasta & "\" & pdf                                      NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"                                  Sheets("teste").Range("C2").Value = Adobefile                                      Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"                                                       Name NomeAntigo As NomeNovo                                                                  ' DoEvents                                         Loop                       ' MsgBox "Nomes dos arquivos alterados!", vbOKOnly, "Processo Concluído"                                                Next                       Next           ' MsgBox ("Arquivos Encontrados = ") & (linha - 1)                    End Sub Já tentei de tudo, e não consegui resolver esse problema, se eu remover o Do while, ele executa normalmente, porem não renomeia os arquivos. Seu eu faço esse laço, ele renomeia só o primeiro e trava geral.
       
      Qualquer esclarecimento, agradeço.

       
    • Por Omar~
      Opa!
      Então.... como eu faria uma query que me retornasse apenas colunas cujo seu valor seja duplicado estou meio confuso como proceder?
      Digamos uma query para exemplificar melhor:
      SELECT * FROM tabela
      E teria um resultado assim:
      $resultado = [ 0 => [ 'id' => 1, 'repetido' => 'abcde' ], 1 => [ 'id' => 2, 'repetido' => 'aaaaa' ], 2 => [ 'id' => 3, 'repetido' => 'abcde' ], 3 => [ 'id' => 4, 'repetido' => 'bbbbb' ], ]; Então no índice 0 e no índice 2 tenho a coluna com o valor repetido.
      Como eu poderia esta fazendo a query de forma que me retornasse somente os resultados que são repetidos?
      Lembrando que não indicarei o valor de busca, pois foi isso que me pegou e não estou sabendo como proceder... 
       
      Até onde eu sei usei a lógica e não deu certo:
      SELECT id, repetido FROM tabela GROUP BY repetido HAVING COUNT(repetido) > 1 Pois dessa forma só me retorna o último índice repetido e eu preciso de todos que forem repetidos.
    • Por kendy1290
      Olá! Estou com problema referente a exportação de gráficos do Excel via VBA para apresentação do PowerPoint. A maneira que encontrei, inclusive em várias fontes é de exportar vários gráficos de uma vez ou uma ,em uma nova apresentação. O que estou precisando é de exportar os gráficos do Excel em um arquivo do PowerPoint existente, em slides e locais específicos das apresentações. Se alguém tiver alguma  ideia de como fazer seria de muita ajuda. 
×

Informação importante

Ao usar o fórum, você concorda com nossos Termos e condições.