Usuário com melhor resposta
Erro ao transferir dados de Listview para Planilha

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?
- Editado Carlos H V Brito segunda-feira, 13 de abril de 2015 16:00
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
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
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.
-
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