< návrat zpět

MS Excel


Téma: makro Zkopírovat jeden list do dvou dalších rss

Zaslal/a 19.5.2012 17:11

lajosZdraví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 =

Zaslat odpověď >

#008560
lajos
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
#008561
avatar
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
#008562
lajos
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
#008563
avatar
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
#008565
lajos
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
#008566
avatar
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 knizkacitovat
#008568
lajos
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
#008570
avatar
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

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje