Problema com codigo

olá pessoal queria uma ajuda no codigo abaixo ele insere em um Userforme so o nome do aluno e ue quero inserir na ListBox o nome e o telefone so que quando vou alterar o codigo para que apareça o telefone o mesmo fica embaixo do nome e eu quero do lado do nome na ListBox alguém pode ajudar no codigo

'Este código deve residir no módulo de um formulário contendo:
'ComboBox1 - caixa de combinação que lista matérias
'ComboBox2 - caixa de combinação que lista turnos
'ListBox1 - caixa de listagem que lista alunos, resultantes de uma pesquisa

'Considere que na coluna A possui o nome dos alunos, na B o nome
'das matérias de cada aluno e na coluna C o turno das aulas.
'A planilha deve conter uma linha de cabeçalho.

'Altere aqui para o nome da planilha que possui os dados:
Const mcsSheetName As String = "Plan1"

Dim moSheet As Excel.Worksheet
Dim mlLast As Long

Private Sub UserForm_Initialize()
 Dim clc As VBA.Collection
 Dim s As String
 Dim l As Long
 
 Set moSheet = ThisWorkbook.Worksheets(mcsSheetName)
 Set clc = New VBA.Collection
 With moSheet
   mlLast = .Cells(.Rows.Count, "B").End(xlUp).Row
   
   'Armazena numa coleção todas as matérias disponíveis:
   On Error Resume Next
   For l = 2 To mlLast
     s = .Cells(l, "B")
     clc.Add s, s
   Next l
   On Error GoTo 0
   'Povoa a caixa de combinação de matérias:
   For l = 1 To clc.Count
     ComboBox1.AddItem clc(l)
   Next l
 End With
 
 'Preencher caixa de combinação de turno:
 ComboBox2.AddItem "Manhã"
 ComboBox2.AddItem "Tarde"
 ComboBox2.AddItem "Noite"
End Sub

Private Sub CommandButton1_Click()
 Dim clc As VBA.Collection
 Dim l As Long
 Dim s As String
 
 ListBox1.Clear
 Set clc = New VBA.Collection
 With moSheet
   'Armazena numa coleção todos os alunos disponíveis:
   For l = 2 To mlLast
     If .Cells(l, "B") Like "*" & ComboBox1 _
     And .Cells(l, "C") Like "*" & ComboBox2 Then
       On Error Resume Next
       s = .Cells(l, "A")
       clc.Add s, s
       On Error GoTo 0
     End If
   Next l
   'Povoa a caixa de listagem de alunos:
   For l = 1 To clc.Count
     ListBox1.AddItem clc(l)
   Next l
 End With
End Sub

Boa tarde!!

Já resolveu seu problema?

Caso não poste seu arquivo modelo!


Att

Boa tarde. Estou com um problema para resolver no código que vou deixar em baixo. A macro que estou a usar exporta para .txt a planilha toda. No entanto eu queria apenas exportar um range do género ("A1:C100"), mas não estou a conseguir. Alguém me consegue ajudar. Desde já agradeço pela atenção.

Sub Exportar()
   Application.DisplayAlerts = False

   template_file = ActiveWorkbook.FullName

   fileSaveName = Application.GetSaveAsFilename( _
                  InitialFileName:="C:\" + "saida.txt", _
                  fileFilter:="Text Files (*.txt), *.txt")

   If fileSaveName = False Then
       Exit Sub
   End If

   'cria uma cópia da pasta de trabalho atual da planilha atual
   Dim newBook As Workbook
   Dim plan As Worksheet
   Set newBook = Workbooks.Add

   ThisWorkbook.ActiveSheet.Copy Before:=newBook.Sheets(1)

   'exclui as demais planilhas
   For Each plan In newBook.Sheets
       If plan.Name <> ActiveSheet.Name Then
           newBook.Worksheets(plan.Index).Delete
       End If
   Next

   newBook.SaveAs Filename:= _
                         fileSaveName, FileFormat:=xlTextWindows, _
                         CreateBackup:=False

   'fecha a pasta de trabalho gerada
   newBook.Close SaveChanges:=True
   Set newBook = Nothing

   MsgBox "O arquivo foi exportado com sucesso! ", vbInformation, "Exportar arquivos"

End Sub

Boa tarde!!

Na próxima vez, crie seu próprio post!!!

Altere a linha

Código:

ThisWorkbook.ActiveSheet.Copy Before:=newBook.Sheets(1)

Para

Código:

ThisWorkbook.ActiveSheet.Range("A1:C100").Copy Before:=newBook.Sheets(1)

Eu não testei o código!!!

Att

Boa tarde!!

Caso não consiga adaptar, tente assim.

Código:

Sub Selecione_Intervalor()
'esta versão permite que o usuário selecione o intervalo desejado.
    Dim rRange As Range
    Dim ws As Worksheet
    Dim stTextName As String
   
   
    On Error Resume Next
    Application.DisplayAlerts = False
    Set rRange = Application.InputBox(Prompt:= _
    "Por favor selecione o intervalo para salvar como .txt.", _
    Title:="Exportar para .txt", Type:=8)
    On Error GoTo 0
    Application.DisplayAlerts = True
   
    If rRange Is Nothing Then
        Exit Sub
    Else
        stTextName = Replace(ThisWorkbook.Name, ".xls", "")
        Set ws = Worksheets.Add()
        rRange.Copy ws.Cells(1, 1)
        ws.Move
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs _
        Filename:="C:\Users\SueUsuario\Downloads\" & stTextName, _
        FileFormat:=xlText
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
    End If
   
End Sub

Código:

Sub Selecione_Intervalor2()
'esta versão tem o intervalo fixo de "A1:C100"
    Dim rRange As Range
    Dim ws As Worksheet
    Dim stTextName As String
   
   
    On Error Resume Next
    Application.DisplayAlerts = False
    Set rRange = Range("A1:C100")
    On Error GoTo 0
    Application.DisplayAlerts = True
   
    If rRange Is Nothing Then
        Exit Sub
    Else
        stTextName = Replace(ThisWorkbook.Name, ".xls", "")
        Set ws = Worksheets.Add()
        rRange.Copy ws.Cells(1, 1)
        ws.Move
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs _
        Filename:="C:\Users\SeuUsuario\Downloads\" & stTextName, _
        FileFormat:=xlText
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
    End If
   
End Sub

Att

Boa tarde alexandrevba,

Desde já agradeço a sua disponibilidade para ajudar.Obrigado pela sugestão mas essa alteração de linha eu já tinha tentado e da erro (Run time erros 1004) application-defined or object - defined error. Em relação as suas propostas a primeira da exactamente o mesmo erro que descrevi em cima, e a segunda sugestão da erro também. No entanto agradeço na mesma o seu apoio. O macro que eu partilhei funciona muito bem, o problema e que exporta a planilha toda.Em relação ao tópico, sou novo neste forum e ainda não percebi muito bem seu funcionamento, peço desculpa por isso.

Cumprimentos

Bom dia!!


Acontece que nos dois códigos que eu postei, o caminho no diretório já vem definido, o usuário não tem chance de escolher o local.

Você alterou essa parte

Código:

Filename:="C:\Users\SueUsuario\Downloads\" & stTextName, _

para o local que deseja salvar o arquivo em txt.

Os dois código foram testados antes de ser postados, eu não tive erro.

Att

Obrigado pela sua ajuda. Sim estava a por o caminho apenas para a raiz do C: e como não tenho acesso administrativo nesta maquina estava a dar erro. A macro e exelente, mas no meu caso e muito importante escolher onde se grava e poder dar nome ao ficheiro(embora o nome do ficheiro ate possa vir da macro porque a partida será sempre o mesmo). Agradeço mais uma vez a sua ajuda.

Cumprimentos

Boa tarde!!

veja se ajuda...

Código:

Sub AleVBA_952()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbDest As Workbook
Dim fName As String

Set wbSource = ActiveWorkbook
Set wsSource = ActiveSheet
Set wbDest = Workbooks.Add

wsSource.Range("A1:C100").Copy
  wbDest.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    fName = Application.GetSaveAsFilename(FileFilter:="Text Files (*.txt), *.txt", Title:="Save As")
    If fName = "" Then Exit Sub
  wbDest.SaveAs fName, xlText
wbDest.Close SaveChanges:=True

End Sub

Att

Boa noite!!

Tente também

Código:

Sub AleVBA_952V2()
    Dim z, x, i As Long, ii As Long, fldr As FileDialog, SelFold As String


    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecione o Diretório"
        If .Show <> -1 Then Exit Sub
        SelFold = .SelectedItems(1)
    End With
   
    x = [A1:C100]
    ReDim z(1 To UBound(x))
    For i = LBound(x) To UBound(x)
        For ii = LBound(x, 2) To UBound(x, 2)
            z(i) = z(i) & x(i, ii)
        Next ii
    Next i
        CreateObject("scripting.filesystemobject").CreateTextFile(SelFold & "\Saida.txt").write Join(z, vbCrLf)

End Sub

Boa tarde alexandrevba,

Muito obrigado pela sua ajuda. O primeiro código funciona na perfeição.O segundo também funciona mas apenas esta a exportar a coluna A. Em relação ao primeiro código, ele da o nome por defeito para a gravação de livro1.txt. E possível alterar o nome para um nome predefinido? Já agora aproveito para perguntar qual é para si e a melhor forma de aprender vba. Pode me dar algumas dicas por onde começar e qual a melhor forma na sua opinião para aprender.

Cumps

Bom dia!

Altere a linha

Código:

fName = Application.GetSaveAsFilename(FileFilter:="Text Files (*.txt), *.txt", Title:="Save As")

Para

Código:

fName = Application.GetSaveAsFilename("AleVBA", FileFilter:="Text Files (*.txt), *.txt", Title:="Save As")

Onde está escrito AleVBA, mude como preferir.

Quanto ao aprender VBA, o ideal seria fazer um curso específico em VBA, ler e pesquisar bastante.

Apostila de VBA
http://www.bertolo.pro.br/FinEst/SemanaContabeis2007/MacroExcel.pdf

Eu te garanto que a pesquisa funciona, pois eu até hoje não sei quase nada sobre Excel e muito menos VBA. mas tem muitas coisas que eu resolvo pesquisando!!


Att

Bom dia alexandrevba,


Obrigado pela sua ajudar mais uma vez.Depois de alguma pesquisa eu consegui resolver o problema com a seguinte alteração.

fName= Application.GetSaveAsFilename(InitialFileName:= "C:\" + "nome_que_quero", fileFilter:=" Text Files (*.txt), *.txt)

Deve fazer o mesmo que o alexandre sugeriu. Obrigado pela sua ajuda vou começar a ver essa apostila que sugeriu.Estou a ficar viciado no VBA. Já agora lanço o ultimo desafio.E possível que ele vá buscar o nome do ficheiro que vai sugerir na gravação a uma célula em especifico??Ou seja, por exemplo na celula A2 esta escrito VBA, quando clico no botão de exportar ele sugere logo VBA.txt! E possível? Obrigado mais uma vez, não me canso de agradecer mas admiro muito as pessoas como o alexandre que estão sempre dispostas a partilhar o conhecimento e ajudar os outros. Espero um dia poder retribuir.

Cumps

Bom dia!!

Talvez algo desse tipo..

Código:

Sub AleVBA_952()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbDest As Workbook
Dim fName As String
Dim nmCelula As Range 'Foi acrescentado

Set wbSource = ActiveWorkbook
Set wsSource = ActiveSheet
Set wbDest = Workbooks.Add
Set nmCelula = Range("A1") 'Foi acrescentado

wsSource.Range("A1:C100").Copy
  wbDest.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    '--------------------------------->Veja abaixo
    fName = Application.GetSaveAsFilename(nmCelula, FileFilter:="Text Files (*.txt), *.txt", Title:="Save As")
    If fName = "" Then Exit Sub
  wbDest.SaveAs fName, xlText
wbDest.Close SaveChanges:=True

End Sub

Obs: Não testado!!!


Att

Boa tarde alexandrevb,

O alexandre é craque mesmo. Está perfeito, faz tudo o que eu preciso e ja entendo bem a programaçao da macro. So falha mesmo num detalhe que nao sei se é possivel sequer corrigir. Eu tenho 3 livros no mesmo ficheiro exel. Tenho um botão para exportar para txt em cada livro. Quando eu exporto o 1 livro eu indico o caminho onde eu quero que guarde, quando eu passo para o 2 livro e faço exportar eu tenho que indicar novamente o caminho para essa mesma pasta onde eu guardei o livro 1. E no 3 livro acontece o mesmo. É possivel que ele guarde o historico do caminho onde guardou o 1 livro para depois quando exportar o 2 livro ja estar na pasta certa?

Cumps

Boa tarde alexandrevb,

Já consegui resolver alexandre. O único problema que eu reparei agora e que quando eu clico no botão exportar e em vez de ok carrego cancelar ele exporta um ficheiro na mesma, embora atribua o nome false.txt E possível que quando carrego cancelar ele não exporte nenhum ficheiro?Obrigado.

Cumps

Bom dia!!

Eu não sei se entendi sua ultima postagem, tu deseja que ao clickar em cancelar, o livro não seja carregado?

Lembre se, ele (arquivo), não será salvo e nem exportado para seu diretório!

Caso ocorra algum erro, faça os devidos tratamentos.

Código:

  On Error Resume Next

Para mais veja:
http://www.ambienteoffice.com.br/officevba/tratamento_de_excecao/#on_error_resume_next

Att

Bom dia alexandrevba,

Ainda nao tinha tido tempo para passar ca. Mas ja resolvi os problemas que me foram surgindo.

Obrigado,

Cumps

Bom dia!!

Eu fico muito feliz, por você ter resolvido sua dúvida, obrigado pelo retorno!!


Att