přenesení dat z listu1 do jiného listu Vyřešeno

[esi32]

Dobrý den,
Pomocí záznamníku maker jsem "vytvořil" makro,které mi importuje csv.soubor do listu,dále mi mi odtraní nepotřebné sloupce,pak změní ve sloupci "B" formát buněk a nakonec mi prohodí pořadí prvního a posledního sloupce..Dál si nevím rady.Potřeboval bych,aby tento list nakopírovalo do dvou dalších listů na první prázdný řádek.Na cílových listech je pořadí sloupců jiné,než na tomto výchozím listě.(to bych snad v makru eventuelně dokázal upravit sám).Dokázal by někdo takové makro vytvořit?
Děkuji za případnou pomoc.

Kód: Vybrat vše

Private Sub CommandButton1_Click() '++++++++++++++++++++++++++++++++++++++++ import csv.souboru-odkud kam

 With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\Notebook\Downloads\dataexport.csv", Destination:=Range("Import!$A$1") _
        )
        .Name = "dataexport"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1250
        .TextFileStartRow = 2
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
       
       
        Range("C:C,D:D,P:P,Q:Q,R:R").Select '+++++++++++++++++++++++++++++++Vybere sloupce C:D,smaže obsah bunek a odstraní sloupce
        Selection.ClearContents
        Selection.Delete Shift:=xlToLeft
       
        Columns("B:B").Select '+++++++++++++++++++++++++++++++Vybere B sloupec a nastaví formát datumu
        Selection.NumberFormat = "m/d/yyyy"
       
        Columns("R:R").Select '++++++++++++++++++++++++++++++++přehození prvního a posledního sloupce
        Range("R1").Activate
        Selection.Copy
        Columns("S:S").Select
        Range("S1").Activate
        ActiveSheet.Paste
        Columns("R:R").Select
        Range("R1").Activate
        Application.CutCopyMode = False
        Selection.ClearContents
        Columns("A:A").Select
        Selection.Copy
        Columns("R:R").Select
        ActiveSheet.Paste
        Columns("S:S").Select
        Application.CutCopyMode = False
        Selection.Copy
        Columns("A:A").Select
        ActiveSheet.Paste
        Columns("S:S").Select
        Application.CutCopyMode = False
        Selection.ClearContents
       
     
                               
    End With
End Sub


[Reklama]

[esi32]

Zdravím Vás,
tak jsem s pomocí vláken na foru částečně problém vyřešil.Již dokážu data z listu Import dostat do listu Klienti,ale nedaří se mi makro donutit,aby stejný obsah zároveň zapsal i do listu Archiv.Mohl by se někdo znalý na kod podívat a pomoci?

Kód: Vybrat vše

Private Sub CommandButton1_Click() '++++++++++++++++++++++++++++++++++++++++ import csv.souboru-odkud kam
      Application.ScreenUpdating = False
 With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;\\Freenas\Hdd1\Excell\dataexport.csv", Destination:=Range("Import!$A$1") _
        )
        .Name = "dataexport"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1250
        .TextFileStartRow = 2
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
       
       
        Range("C:C,D:D,P:P,Q:Q,R:R").Select '+++++++++++++++++++++++++++++++Vybere sloupce C:D,smaže obsah bunek a odstraní sloupce
        Selection.ClearContents
        Selection.Delete Shift:=xlToLeft
       
        Columns("B:B").Select '+++++++++++++++++++++++++++++++Vybere B sloupec a nastaví formát datumu
        Selection.NumberFormat = "m/d/yyyy"
       
        Columns("R:R").Select '++++++++++++++++++++++++++++++++přehození prvního a posledního sloupce
        Range("R1").Activate
        Selection.Copy
        Columns("S:S").Select
        Range("S1").Activate
        ActiveSheet.Paste
        Columns("R:R").Select
        Range("R1").Activate
        Application.CutCopyMode = False
        Selection.ClearContents
        Columns("A:A").Select
        Selection.Copy
        Columns("R:R").Select
        ActiveSheet.Paste
        Columns("S:S").Select
        Application.CutCopyMode = False
        Selection.Copy
        Columns("A:A").Select
        ActiveSheet.Paste
        Columns("S:S").Select
        Application.CutCopyMode = False
        Selection.ClearContents
     
   
     
     Dim PWsht As Worksheet, PBlk As Range, PCll As Range, PFRw As Range
  Dim AWsht As Worksheet, ABlk As Range, AFRw As Range, AOfsR As Long
  Dim i As Long
  ' definice bloku
  Set PWsht = ActiveWorkbook.Worksheets("Import")  ' list
  Set PFRw = PWsht.Range("a1:r1")  ' prvni radek
  Set AWsht = ActiveWorkbook.Worksheets("Klienti")
  Set AFRw = AWsht.Range("a1:r1")
  ' blok zaznamu na listu prepis
  With PWsht
    If Len(.Range("a1").Value) > 0 Then
      ' pocet radku obsahujicich zaznamy na listu prepis
      i = 0
      For Each PCll In .Range("a1:a500").Cells
        If Len(PCll.Value) > 0 Then i = i + 1
      Next PCll
      ' definovat blok zaznamu na listu prepis
      Set PBlk = PFRw.Resize(i, PFRw.Columns.Count)
      ' nastavit ofset pro prvni volny radek na listu archiv
      With AWsht
        If Len(.Range("a1").Value) = 0 Then
          Set ABlk = AFRw
        Else
          Set ABlk = .Range("A1:R" & .Cells(1, 1).End(xlDown).Row)
        End If
        AOfsR = ABlk.Rows.Count  ' ofset prvniho volneho radku
      End With
      ' prenest zaznamy z listu prepis na list archiv
      AFRw.Resize(i, AFRw.Columns.Count).Offset(AOfsR, 0).Value = PBlk.Value
    Else
      MsgBox "Na listu prepis nejsou zaznamy k prevodu do archivu"
    End If
  End With
  ' odstranit objektove promenne
  Set PWsht = Nothing
  Set PBlk = Nothing
  Set PCll = Nothing
  Set PFRw = Nothing
  Set AWsht = Nothing
  Set ABlk = Nothing
  Set AFRw = Nothing
                                   
    End With
End Sub