< návrat zpět
MS Excel
Téma: makro Zkopírovat jeden list do dvou dalších
Zaslal/a lajos 19.5.2012 17:11
Zdravím,mám udělané makro,které mi provede import dat z csv.souboru,pak mi odstraní nepotřebné sloupce a přehodí pořadí sloupců.Pak mi list nakopíruje do jiného listu do prvního volného řádku.Nedaří se mo ho donutit,aby mi to kopírovalo ještě do dalšího listu.Tedy do dvou listů najednou.Poradí někdo,co v kodu upravit?
Dík za případnou pomoc.
[ Private Sub CommandButton1_Click() '++++++++++++++++++++++++++++++++++++++++ import csv.souboru-odkud kam
Application.ScreenUpdating =
lajos(19.5.2012 17:12)#008560 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
citovat
misocko(19.5.2012 19:57)#008561 nestudoval som kod, ale ak sa to snazis ako pises skopirovat "najednou" tak to nejde, musis to kopirovat na dvakrat (pripadne ak by to bolo viackrat tak sa uz oplati robit cyklus)
citovat
lajos(19.5.2012 20:06)#008562 Ahoj Mišočko,tedy jedním stiskem jednoho tlačítka to neudělám?Studovat to nemusíš,jen bych potřeboval vědět,jak na to.Makro se mi zastaví po zkopírování na první list.Jak mu tedy mám říct,aby pokračovalo dál.To právě nevím.
citovat
Jeza(19.5.2012 21:09)#008563 Taky jsem nestudoval, nicméně jedním stiskem tlačítka ANO, ale po jednom, tzn. spustit ten cyklus 2x, což ještě nutně neznamená psát ho 2x pod sebe :-), ikdyž i to je možnost. Existují smyčky for i = 1 to 2 ... next pak je ale potřeba místo fixních názvů použít proměnné závislé na cyklu.
M@
citovat
lajos(19.5.2012 22:32)#008565 No tak vysvětlili jste mi to oba pěkně.Teoreticky to už chápu,ale jak to napsat,tak to je pro mě neřešitelný problém.Tady záznamník asi nepomůže.Nemůžete mě nakopnout třeba nějakým kodem,kde to je a že bych to zkusil najít?
citovat
misocko(20.5.2012 9:20)#008566 ahoj
tu je rozdile v zaznamenanom a cyklovom makre
Sub zaznamenane()
Sheets("List1").Select
Range("A1:G20").Select
Range("G20").Activate
Selection.Copy
Sheets("List2").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("List3").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("List4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("List5").Select
Range("A1").Select
ActiveSheet.Paste
End Sub
Sub cyklus()
pole_listov = Array("List2", "List3", "List4", "List5") 'nadefinovanie listov do ktorych chces kopirovat
'*********** Ctrl + C *****************
Sheets("List1").Select
Range("A1:G20").Select
Range("G20").Activate
Selection.Copy
'******************************************
For x = 0 To UBound(pole_listov) 'prejde vsetky polozky v poli pole_listov (skus help, nebudem to tu rozpisovat)
Sheets(pole_listov(x)).Select ' select x-tej polozky z pole_listov (v prvom cykle x=0, nulta polozka v poli je "List2", v druhom cykle x=1 atd...)
Range("A1").Select
ActiveSheet.Paste ' Ctrl + V
Next x ' dalsie x, zas je to na help
End Sub
PS anglictina Ti ide? neviem ci uz su nejake helpy aj v cestine, ak sa tomu chces nejako venovat je na to dobra knizka
citovat
lajos(20.5.2012 11:35)#008568 Dík za nakopnutí.Už se s tím nějak poperu.Anglicky umím,to není problém.Ještě jednou dík.
citovat
kp57(20.5.2012 15:37)#008570 Pokud se nejedná o PasteSpecial, proč Activate, Select.
Stačí přímo,
Sheets("List1").Activate
With ActiveSheet.Range(Cells(1, 1), Cells(10, 10))
.Copy Sheets("List2").Cells(1, 1)
.Copy Sheets("List3").Cells(1, 1)
End With
nebo v cyklu
For xL = 2 To 3
ActiveSheet.Range(Cells(1, 1), Cells(10, 10)).Copy Sheets(xL).Cells(1, 1)
Next xL
citovat