none
Erro ao transferir dados de Listview para Planilha RRS feed

  • Pergunta

  • Bom dia Pessoal,

    Meu caso é o seguinte:

    Tenho um formulário de Pesquisa que filtra os dados de uma planilha, "Dados", para uma listview neste formulário.

    A pesquisa é feita de duas formas por data e por nome. E ao dar um Duplo Clique em um dos itens da listview, os dados do listview são copiados para outra planilha, DadosTemp" e um novo formulário se abre com os dados do item clicado já carregados.

    Quando faço a pesquisa por data, não tem problema, tudo ocorre como deveria.

    Meu problema é quando faço a pesquisa por nome.

    Este é o código da pesquisa por nome:

    'Consulta Nome'
    Sub nome_Change()
    
              lastRow = Plan2.Cells(Rows.Count, "a").End(xlUp).Row
              lstLista.ListItems.Clear
              
             'Adiciona itens'
            For x = 2 To lastRow
                If UCase(Plan2.Cells(x, 2)) Like "*" & UCase(nome) & "*" Then
                    Set li = lstLista.ListItems.Add(Text:=Plan2.Cells(x, "a").Value)
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "b").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "c").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "d").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "e").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "f").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "g").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "h").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "i").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "j").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "k").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "l").Value
                    li.ListSubItems.Add Text:=Plan2.Cells(x, "m").Value
                End If
            Next
        End Sub

    Este é o código que abre o novo formulário e chama a rotina de copiar os dados para a planilha "DadosTemp":

    ' Carrega o cadastro selecionado'
    Private Sub lstLista_DblClick()
    Dim linha, Index
    Dim I As Integer
    Dim oList As Object
    Dim indiceRegistro As Long
    
    Call PlanTmp
    
    Set oList = lstLista.SelectedItem
        
        If oList Is Nothing Then
         Exit Sub
       
         Else
                indiceRegistro = cmsCadastro.ProcuraIndiceRegistroPodId(lstLista.ListItems.Item(lstLista.SelectedItem.Index))
                         If indiceRegistro <> -1 Then
                            Call cmsCadastro.CarregaRegistroPorIndice(indiceRegistro)
                        End If
                 Unload Me
        End If
        cmsCadastro.Show
    End Sub

    Este é o código da rotina de cópia dos dados para a planilha "DadosTemp"

    Private Sub PlanTmp()
        Dim iLin As Integer
        Dim rgCellInicio As Range
        Dim wsRelat As Worksheet
        Dim UltimaLinha As Long
        
        Set wsRelat = ThisWorkbook.Worksheets(NomePlanRelatorio)
    
        UltimaLinha = wsRelat.UsedRange.Rows.Count
        
        wsRelat.Range("A2:" & "M" & UltimaLinha).ClearContents
        
        Set rgCellInicio = wsRelat.Range("A65536").End(xlUp).Offset(1, 0)
    
            'recuperar dados'
             Dim I As Integer, j As Integer
                
                'Loop nas linhas'
                For I = 1 To lstLista.ListItems.Count
                    
                    iLin = iLin + 1
                    
                            rgCellInicio.Cells(iLin, 1).Value = lstLista.ListItems(I).Text
                    
                        'Loop nas colunas'
                        For j = 1 To lstLista.ColumnHeaders.Count - 1
                            rgCellInicio.Cells(iLin, j + 1).Value = lstLista.ListItems(I).ListSubItems(j).Text
                        Next j
                Next I
        
           
    End Sub

    E aqui é onde ocorre o erro "35600 - Index out of Bound" dentro do código de copia dos dados:

     'Loop nas colunas'
                        For j = 1 To lstLista.ColumnHeaders.Count - 1
                            rgCellInicio.Cells(iLin, j + 1).Value = lstLista.ListItems(I).ListSubItems(j).Text
                        Next j

    Então minha questão é: como posso fazer para que o erro não aconteça e os dados sejam copiados corretamente?


    segunda-feira, 13 de abril de 2015 15:59

Respostas

  • Bom dia Pessoal,

    Já consegui resolver o problema, eu utilizei o código abaixo:

    Private Sub PlanTmp()
        Dim iLin As Integer
        Dim rgCellInicio As Range
        Dim wsRelat As Worksheet
        Dim UltimaLinha As Long
        
        Set wsRelat = ThisWorkbook.Worksheets(NomePlanRelatorio)
    
        UltimaLinha = wsRelat.UsedRange.Rows.Count
        
        wsRelat.Range("A2:" & "M" & UltimaLinha).ClearContents
        
        With wsRelat
            For I = 1 To lstLista.ListItems.Count
                .Cells(I + 1, 1) = lstLista.ListItems(I).Text
                .Cells(I + 1, 2) = lstLista.ListItems(I).SubItems(1)
                .Cells(I + 1, 3) = lstLista.ListItems(I).SubItems(2)
                .Cells(I + 1, 4) = lstLista.ListItems(I).SubItems(3)
                .Cells(I + 1, 5) = lstLista.ListItems(I).SubItems(4)
                .Cells(I + 1, 6) = lstLista.ListItems(I).SubItems(5)
                .Cells(I + 1, 7) = lstLista.ListItems(I).SubItems(6)
                .Cells(I + 1, 8) = lstLista.ListItems(I).SubItems(7)
                .Cells(I + 1, 9) = lstLista.ListItems(I).SubItems(8)
                .Cells(I + 1, 10) = lstLista.ListItems(I).SubItems(9)
                .Cells(I + 1, 11) = lstLista.ListItems(I).SubItems(10)
                .Cells(I + 1, 12) = lstLista.ListItems(I).SubItems(11)
                .Cells(I + 1, 13) = lstLista.ListItems(I).SubItems(12)
            Next
        End With
       
    End Sub

    • Marcado como Resposta Carlos H V Brito quarta-feira, 15 de abril de 2015 14:28
    quarta-feira, 15 de abril de 2015 14:28

Todas as Respostas

  • O correto não seria como mostrado abaixo?

    For j = 0 To lstLista.ColumnHeaders.Count - 1


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    terça-feira, 14 de abril de 2015 01:25
    Moderador
  • O correto não seria como mostrado abaixo?

    For j = 0 To lstLista.ColumnHeaders.Count - 1


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    Felipe,

    Obrigado pela ajuda, mas não deu certo, dessa forma não chegou nem a preencher a primeira linha de dados.

    O erro acusado pelo depurador está na segunda linha "rgCellInicio..." mas o que não entendo é por que só não funciona quando uso esta rotina de pesquisa.

    Quando faço a pesquisa com o código abaixo tudo funciona certo.

    'Filtrar pelas Datas'
    Private Sub cbtSo2Dts_Click()
        Dim I As Long
            
            For I = lstLista.ListItems.Count To 1 Step -1
                If CDate(lstLista.ListItems(I).SubItems(5)) < datai.Value Then
                    lstLista.ListItems.Remove I
                ElseIf CDate(lstLista.ListItems(I).SubItems(5)) > dataf.Value Then
                    lstLista.ListItems.Remove I
                End If
            Next
    
    End Sub

    Quando a pesquisa é feita com o código acima tudo funciona, mas quando faço a pesquisa com o código "nome_Change ()" do primeiro post eu recebo este erro.

    terça-feira, 14 de abril de 2015 11:21
  • Bom dia Pessoal,

    Já consegui resolver o problema, eu utilizei o código abaixo:

    Private Sub PlanTmp()
        Dim iLin As Integer
        Dim rgCellInicio As Range
        Dim wsRelat As Worksheet
        Dim UltimaLinha As Long
        
        Set wsRelat = ThisWorkbook.Worksheets(NomePlanRelatorio)
    
        UltimaLinha = wsRelat.UsedRange.Rows.Count
        
        wsRelat.Range("A2:" & "M" & UltimaLinha).ClearContents
        
        With wsRelat
            For I = 1 To lstLista.ListItems.Count
                .Cells(I + 1, 1) = lstLista.ListItems(I).Text
                .Cells(I + 1, 2) = lstLista.ListItems(I).SubItems(1)
                .Cells(I + 1, 3) = lstLista.ListItems(I).SubItems(2)
                .Cells(I + 1, 4) = lstLista.ListItems(I).SubItems(3)
                .Cells(I + 1, 5) = lstLista.ListItems(I).SubItems(4)
                .Cells(I + 1, 6) = lstLista.ListItems(I).SubItems(5)
                .Cells(I + 1, 7) = lstLista.ListItems(I).SubItems(6)
                .Cells(I + 1, 8) = lstLista.ListItems(I).SubItems(7)
                .Cells(I + 1, 9) = lstLista.ListItems(I).SubItems(8)
                .Cells(I + 1, 10) = lstLista.ListItems(I).SubItems(9)
                .Cells(I + 1, 11) = lstLista.ListItems(I).SubItems(10)
                .Cells(I + 1, 12) = lstLista.ListItems(I).SubItems(11)
                .Cells(I + 1, 13) = lstLista.ListItems(I).SubItems(12)
            Next
        End With
       
    End Sub

    • Marcado como Resposta Carlos H V Brito quarta-feira, 15 de abril de 2015 14:28
    quarta-feira, 15 de abril de 2015 14:28