posli jeden (ak su vsetky formatovo rovneke) origo list - data nejak poprepisuj musim vidiet formatovanie buniek a ktore su plne a ktore prazdne, vsetky maju rovnaky pocet riadkov?citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Spojení listu do 1
MS Excel
Téma: Spojení listu do 1 
Zaslal/a milotaho 13.5.2011 22:07
Dobrý den,
V práci máme 6 sešitů které mají cca 150 listu. V číselní řadě viď příloha. (Jsou to kontrolní plány pro kontrolu jakosti, nemůžu poskytnout originál, na každém listu je jedna stránka A4.)
Chtěl bych se zeptat jestli by bylo možné napsat makro které by spojilo pod sebe obsah listu zakončeních _1 / _2 atd. do hlavního listu z názvem 1000/1001 .Kde _1/2/3 je neznáma je v rozmezí 1 až 20. A po zkopírováni listu by se list smazal a zůstaly by jenom listy 1000/1001 atd.
Předem moc děkuji.
Příloha: 
4983_konrolni_plan.zip (3kB, staženo 14x)
4983_konrolni_plan.zip (3kB, staženo 14x)děkuji za rychlou reakci, přišel jsem na to, že to končí většinou 52 řádkem, ale je tam několik listů kde je 54, tak jsem se domluvil, že to ujednotíme, o víkendu sem hodím ten jeden listcitovat
Tak konečně jsem se k tomu dostal. Vytvářel to někdo hoooooodně dávno, takže je to word v tabulkách.
Příloha: 5114_konrolni_plan_1.zip (3kB, staženo 14x)
citovat5114_konrolni_plan_1.zip (3kB, staženo 14x)pozrem na to , nebude problem spojit to ale zachovat strankovanie pre tlac asi bude pre mna trochu oriesok - no nic uvidimecitovat
(1.6.2011 21:35)#005146
stránkováni není problém protože se to bude všechno procházet a redukovat + se nastaví záhlaví a zápatí a moc díkcitovat
skus tento kod, ZALOHUJ SI ORGINALY, "undo alebo zpet" nefubguje, je to na 54 riadkov, este skusam elegantnejsiu verziu , ale to az potom co toto bude OK
ak by to neslo budem potrebovat zopar orginal pomenovanych listov
Sub spoj_listy()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets(1).Select
Sheets.Add
Sheets(1).Select
x = 1
For Each llist In ActiveWorkbook.Sheets
Cells(x, 1).Value = llist.Name
x = x + 1
Next llist
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("B1").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""_"",RC[-1])-1)"
Selection.AutoFill Destination:=Range(Cells(1, 2), Cells(ActiveSheet.UsedRange.Rows.Count, 2)), Type:=xlFillDefault
Range(Cells(1, 2), Cells(ActiveSheet.UsedRange.Rows.Count, 2)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
For riadok = 2 To ActiveSheet.UsedRange.Rows.Count
If Cells(riadok, 1).Value = Cells(riadok - 1, 1).Value Then
Rows(riadok).Delete
riadok = riadok - 1
End If
If Cells(riadok, 1).Value = "" Then GoTo kk
Next riadok
kk:
pocetlistov = ActiveSheet.UsedRange.Rows.Count
For riadok = 1 To pocetlistov
Sheets(1).Select
menolistu = Cells(riadok, 1).Value
Sheets(2).Select
Sheets.Add
Sheets(2).Select
Sheets(2).Name = menolistu
Next riadok
Sheets(1).Select
ActiveWindow.SelectedSheets.Delete
For x = 1 To pocetlistov
For Each llist In ActiveWorkbook.Sheets
If InStr(1, llist.Name, "_") = 0 Then GoTo ky
If Sheets(x).Name = Left(llist.Name, InStr(1, llist.Name, "_") - 1) Then
llist.Activate
Range(Cells(1, 1), Cells(54, 11)).Select
Selection.Copy
Sheets(x).Activate
Cells(Range("h36556").End(xlUp).Row + 2, 1).Select
ActiveSheet.Paste
End If
ky:
Next llist
Next x
End Sub
citovat
ak by to neslo budem potrebovat zopar orginal pomenovanych listov
Sub spoj_listy()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets(1).Select
Sheets.Add
Sheets(1).Select
x = 1
For Each llist In ActiveWorkbook.Sheets
Cells(x, 1).Value = llist.Name
x = x + 1
Next llist
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("B1").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""_"",RC[-1])-1)"
Selection.AutoFill Destination:=Range(Cells(1, 2), Cells(ActiveSheet.UsedRange.Rows.Count, 2)), Type:=xlFillDefault
Range(Cells(1, 2), Cells(ActiveSheet.UsedRange.Rows.Count, 2)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
For riadok = 2 To ActiveSheet.UsedRange.Rows.Count
If Cells(riadok, 1).Value = Cells(riadok - 1, 1).Value Then
Rows(riadok).Delete
riadok = riadok - 1
End If
If Cells(riadok, 1).Value = "" Then GoTo kk
Next riadok
kk:
pocetlistov = ActiveSheet.UsedRange.Rows.Count
For riadok = 1 To pocetlistov
Sheets(1).Select
menolistu = Cells(riadok, 1).Value
Sheets(2).Select
Sheets.Add
Sheets(2).Select
Sheets(2).Name = menolistu
Next riadok
Sheets(1).Select
ActiveWindow.SelectedSheets.Delete
For x = 1 To pocetlistov
For Each llist In ActiveWorkbook.Sheets
If InStr(1, llist.Name, "_") = 0 Then GoTo ky
If Sheets(x).Name = Left(llist.Name, InStr(1, llist.Name, "_") - 1) Then
llist.Activate
Range(Cells(1, 1), Cells(54, 11)).Select
Selection.Copy
Sheets(x).Activate
Cells(Range("h36556").End(xlUp).Row + 2, 1).Select
ActiveSheet.Paste
End If
ky:
Next llist
Next x
End Sub
citovat
co takto napisat sem ci to funguje alebo nefunguje, nechcem ziadne prachy (odpovedal som dobrovolne), nechcem ani "dik" (podakoval si v zadani) ale ak nieco spravim ocakavam odozvu aspon vo forme "OK" alebo "NOK"
dakujem
citovat
dakujem
citovatAhoj předem se omlouvám ale Němci nám vzaly přístup na web, takže sem si to přepsal a ještě nestihl otestovat v práci. ještě jednou se omlouvám a určitě napíšu jestli to funguje a nebo ne.A hlavně dík za pomoccitovat
(18.6.2011 22:30)#005288
Tak po přepsáni se mi to nepovedlo rozchodit hlási to chybu neplatný autofill.Děkuji za snahu ale už si to rozebraly kontroloři a každý to má upravyt protože tam jsou ještě staré data.Takže to musí promazat.Děkujicitovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
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.
RSS nejnovější články