Notifications
Clear all

Copiar e Colar Colunas de forma Dinamica

2 Posts
1 Usuários
0 Reactions
645 Visualizações
(@trindade)
Posts: 0
New Member
Topic starter
 

Boa noite, Senhores.

Estou com um problema punk, tenho um arquivo onde as colunas podem variar entre A ... Z ou até mais, já as linhas sempre serão 12, criei o código abaixo mas não esta transportando o valor para uma nova plan, gostaria de uma ajuda dos senhores.

Código

Public Sub SalvarAnaliseDadosAnualTranspose_Exportar_xls()

Dim Count As Integer
Dim fApp As Excel.Application
Dim fBook As Excel.Workbook
Dim fSheet As Excel.Worksheet

Dim i, UltimaColuna As Long

Dim Arquivo As String
Dim Resultado As VbMsgBoxResult

i = SheetAnaliseDadosAnualTranspose.Cells(1, SheetAnaliseDadosAnualTranspose.Cells.Columns.Count).End(xlToLeft).Column

Arquivo = Application.GetSaveAsFilename(InitialFileName:="", _
        FileFilter:="Pasta de Trabalho do Excel 97-2003 (*.xls), *.xls", _
        Title:="Especifique o nome do arquivo")
        
    If LCase(Arquivo) = "falso" Then Exit Sub

    'Range("A1").Select
    'Range(Selection, Selection.End(xlToRight)).Select
    'Range(Selection, Selection.End(xlDown)).Select
    'Selection.Copy
   
    Set fApp = CreateObject("Excel.Application")
    Set fBook = fApp.Workbooks.Add

    Set fSheet = fApp.ActiveWorkbook.Sheets.Add
    fSheet.Name = "Export"
    fApp.Visible = False
    fSheet.Visible = False
    
    For UltimaColuna = 1 To i
            
        For Count = 1 To 12
        
            With fSheet
                
                .Cells(Count & UltimaColuna).Value = SheetAnaliseDadosAnualTranspose.Cells(Count & UltimaColuna).Value
                
                'MsgBox "Linha: " & Count & vbCrLf & "Coluna: " & UltimaColuna
                
            End With
            
            'Count = Count + 1
            
        Next
        
        'UltimaColuna = UltimaColuna + 1
    
    Next
         
        fSheet.SaveAs Arquivo
            
        fApp.Workbooks.Close
        fApp.Quit
   
    Set fSheet = Nothing
    Set fBook = Nothing
    Set fApp = Nothing
   
    'MsgBox "O arquivo foi salvo com sucesso em [" & Arquivo & "]", vbInformation
    
    Resultado = MsgBox("O arquivo foi salvo com sucesso em [" & Arquivo & "]" & vbCrLf & _
                "Deseja visualizar o arquivo?", vbYesNo, "Arquivo Salvo com Sucesso!")
    
    If Resultado = vbYes Then

        If Len(Dir(Arquivo)) > 0 Then

                    fileToOpen = (Arquivo)
                       Workbooks.OpenText Filename:=fileToOpen, DataType:=xlDelimited, Local:=True
                Else
            Exit Sub
        End If
    End If
   
End Sub
 
Postado : 22/06/2015 8:03 pm
(@trindade)
Posts: 0
New Member
Topic starter
 

Boa tarde, Srs.

Depois quebrar a cabeça hum pouco, consegui encontrar o erro:

Na linha onde está:

.Cells(Count & UltimaColuna).Value = SheetAnaliseDadosAnualTranspose.Cells(Count & UltimaColuna).Value

Deve ser uma " , " (virgula) e não " & " (ampersand) ficando assim:

.Cells(Count, UltimaColuna).Value = SheetAnaliseDadosAnualTranspose.Cells(Count, UltimaColuna).Value
 
Postado : 23/06/2015 1:49 pm