• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

Polovica kódu, je tam len preto aby Vám ukázalo vizuál v bunkách, no makro ich nepotrebuje.
Sub ListFiles()
Dim i As Long, sFile As String, sLeftFile As String, sPath As String, fileSaveName As String, sVal As String, colFiles As New Collection
Dim arrFiles() As String, iFiles As Long, iCol

With ThisWorkbook.Worksheets("Tomas")
sPath = .Cells(1, 4).Value
If Len(sPath) = 0 Or Len(Dir(sPath)) = 0 Then MsgBox "Chýba zdroj", vbCritical: Exit Sub

sFile = Dir(sPath & "*.*", vbNormal)
On Error Resume Next
While sFile <> ""
sLeftFile = Split(sFile, "_")(0)
colFiles.Add Array(sFile, sLeftFile), sLeftFile

If Err.Number = 0 Then
sVal = sVal & IIf(LenB(sVal) = 0, vbNullString, vbCrLf) & sLeftFile
Else
Err.Clear
End If
sFile = Dir()
Wend
On Error GoTo 0
With .Columns(1).Resize(2)
.ClearContents

ReDim arrFiles(1 To colFiles.Count, 1 To 2)
i = 0
For Each iCol In colFiles
i = i + 1
arrFiles(i, 1) = iCol(0)
arrFiles(i, 2) = iCol(1)
Next iCol
.Resize(i, 2).Value = arrFiles
End With
End With

fileSaveName = Application.GetSaveAsFilename(InitialFileName:="c:\1\" & Format(Now, "yyyymmddhhnn"), _
fileFilter:="Semicolon separated CSV (*.csv), *.csv")

If fileSaveName <> "False" Then
i = FreeFile
Open fileSaveName For Output As #i
Print #i, sVal
Close #i
End If
End Sub

Ak to chcete robiť cez Copy, tak to musíte aj niekam prilepiť. A to nerobíte. Pozrite sa napr. sem. Vám tam absentuje vytvorenie cieľového súboru.

EIDT: Alebo to urobte úplne inak, napr. takto, rýchlo, bez kopírovania, bez vytvárania nového okna Excelu:
Sub export_first()
Dim rngArea As Range, i As Long, iRow As Long, sVal As String, arrVal(), fileSaveName As String
With Sheets("Tomas").Range("B1:B20")
arrVal = .Value

For Each rngArea In .SpecialCells(xlCellTypeVisible).Areas
With rngArea
iRow = .Row

For i = iRow To iRow + .Rows.Count - 1
sVal = sVal & IIf(LenB(sVal) = 0, vbNullString, vbCrLf) & arrVal(i, 1)
Next i
End With
Next rngArea

End With
fileSaveName = Application.GetSaveAsFilename(InitialFileName:="c:\1\" & Format(Now, "yyyymmddhhnn"), _
fileFilter:="Semicolon separated CSV (*.csv), *.csv")

If fileSaveName <> "False" Then
i = FreeFile
Open fileSaveName For Output As #i
Print #i, sVal
Close #i
End If
End Sub
Ešte bude záležať na tom, aký typ údajov tam máte.

Príklad:
Cells(10, 5).Interior.Color = RGB(Cells(7, 4), Cells(8, 4), Cells(9, 4))

@AL: A keby ste dal písmo podkladovou farbou, a doplnil ten Váš formát o čiernu farbu ?
[Čierna][>0,02] 0%;[Čierna][<-0,02] -0%; ""
Alebo, musí to byť Vlastný formát ? Nemôžete si pomôcť Podmieneným formátom ?

To preto, lebo listy nemajú rovnaké DPI. Nastavte im rovnaké a pôjde to OK.

EDIT: Konkrétne strany 1, 4 nemajú nastavené žiadne DPI, a strany 2, 3, 5 majú 600 DPI.

No to bude záležať na tom, čo sa má s ktorými súbormi robiť. Nieje vôbec jasné požitie. Či sa distribuuje aj zdroj aj súbory súčasne a spolu, či sa mení cesta k zdroju či cesta k súborom, či môžu obsahovať makro aj samotné súbory, ... nič, žiadne upresnenie... .

Tak to je ale potom zvláštne. Keď tam majú dáta pribúdať, načo potom makrom vkladať vždy na to isté miesto vzorce a formátovať hlavičku ? Veď to urobte raz manuálne, a nepotrebujete na to opakovane makro, zbytočne, lebo to už je vykonané.
A keď si z obyčajnej tabuľky urobíte objekt Tabuľka (Ctrl+T), tak sa budú vzorce kopírovať do ďalších pridaných riadkov automaticky samé.
Otázkou je, akým spôsobom budú pribúdať údaje.
Ak ručne, tak je potreba potom ručne (alebo makrom) reinicializovať opätovné zoradenie.
Ak pribúdajú makrom, treba túto reinicializáciu vyvolať rovno pri importe.

No a na druhej strane, ak tie úpravy potrebujete robiť opakovane na nejaký export súbor od neviem odkiaľ, tak do export/reportu nemôžete pridávať dáta. Potom to už nezodpovedá tomu reportu. A zároveň je to v rozpore toho vyššie spomínaného opakovaného formátovania.

Alebo ???

Tu máte príklad takej Tabuľky. Stačí iba skopírovať z nejakého nového reportu/exportu/výkazu nové dáta na prvý voľný riadok pod Tabuľku. Vzorce v I:J sa doplnia samé. Potom už iba na karte Údaje kliknite v skupine Zoradiť a filtrovať na Znovu použiť. Neviem, či Vám celá operácia zaberie 10 sek. V dátach ale vidím typický neduh týchto exportov - zlý formát dát. Stĺpec A musí byť formát Text (ID materiálov sú aj číselné aj textočíselné, aby to nespôsobovalo problém napr pri vyhľadávaní 0123 vs 123), C:D sú čísla ako text a majú to byť čísla.
-buď ich pri exporte (ak to ide navoliť) exportujte správne
-alebo ich pri importe (ak vôbec importujete, možno máte už hotový súbor xlsx a nie napr. csv a pod.) zformátujte
-alebo použite:
---do bunky niekde bokom dočasne napíšte 1, túto bunku dajte Ctrl+C
---označte celé stĺpce Tabuľky "tblData[[Závod]:[Sklad]]" na hlalvičke týchto stĺpcov
---pravý klik na označené - Prilepiť špeciálne - Hodnoty - Násobenie - OK
---Zmažte tú 1-tku, a sú z toho skutočné čísla.
-alebo označte najskôr v Tabuľke stĺpec Závod (opäť na hlavičke, taká malá šípka), na karte Údaje - Text na stĺpce - Ďalej - Ďalej - Dokončiť. Potom to isté urobte so stĺpcom Sklad.

Všetko sú to jednoduché operácie, a žiadne makro zatiaľ nieje potreba. Usudzujem totiž, že nieje možné použiť súbor s makrom, ak makrom z iného súboru upravujete tento xlsx. Inak by mal predsa tento súbor makro v sebe, a nemuselo by sa to riešiť cez 2 súbory.

Key1:=Range("I1")
musíte zmeniť na
Key1:=Workbooks("sklad_2100.xlsx").Worksheets("Sheet1").Range("I1")
alebo zmente kód na napr. takýto:
Private Sub CommandButton1_Click()
With Workbooks("sklad_2100.xlsx").Worksheets("Sheet1")
.Range("A1:J1300").Sort Key1:=.Range("I1"), Order1:=xlDescending, Header:=xlYes
End With
End Sub

Private Sub Formatovani_Click()
With Workbooks("sklad_2100.xlsx").Worksheets("Sheet1").Range("I1")
.Interior.Color = RGB(0, 255, 0)
.ColumnWidth = 20
.Value = "Rozdíl Fyz. - SAP"
.VerticalAlignment = xlTop
End With

With Workbooks("sklad_2100.xlsx").Worksheets("Sheet1").Range("J1")
.Interior.Color = RGB(255, 255, 0)
.ColumnWidth = 20
.Value = "Absol. hod."
.VerticalAlignment = xlTop
End With

With Workbooks("sklad_2100.xlsx").Worksheets("Sheet1")
.Range("I2:I1300").Formula = "=H2-F2"
.Range("J2:J1300").Formula = "=ABS(I2)"
End With
End Sub

Prípadne obe procedúry dokopy a na menej krokov:
Private Sub Formatovani_Click()
With Workbooks("sklad_2100.xlsx").Worksheets("Sheet1")
With .Range("I1:J1")
.ColumnWidth = 20
.Value = Array("Rozdíl Fyz. - SAP", "Absol. hod.")
.VerticalAlignment = xlTop
End With

.Range("I1").Interior.Color = RGB(0, 255, 0)
.Range("J1").Interior.Color = RGB(255, 255, 0)

.Range("I2:J1300").Formula = Array("=H2-F2", "=ABS(I2)")
.Range("A1:J1300").Sort Key1:=.Range("I1"), Order1:=xlDescending, Header:=xlYes
End With
End Sub
Aj tak sa mi nezdá, to vkladanie vzorcov na 1300 riadkov. Určite ? Netreba to náhodou len na taký počet riadkov, koľko je dát ? Lebo teraz to dá tie záporné hodnoty až za 0 (nuly), čo je od riadku 1300 vyššie.

Takto by mi to viacej dávalo zmysel:
Private Sub Formatovani_Click()
Dim Riadkov As Long
With Workbooks("sklad_2100.xlsx").Worksheets("Sheet1")
With .Range("I1:J1")
.ColumnWidth = 20
.Value = Array("Rozdíl Fyz. - SAP", "Absol. hod.")
.VerticalAlignment = xlTop
End With

.Range("I1").Interior.Color = RGB(0, 255, 0)
.Range("J1").Interior.Color = RGB(255, 255, 0)

Riadkov = .Cells(Rows.Count, 1).End(xlUp).Row
If Riadkov > 1 Then
.Range("I2:J" & Riadkov).Formula = Array("=H2-F2", "=ABS(I2)")
.Range("A1:J" & Riadkov).Sort Key1:=.Range("I1"), Order1:=xlDescending, Header:=xlYes
End If
End With
End Sub

Hmm, tiež neviem, čo presne potrebujete, tak možno len inšpirácia...

Funguje to. ALE ! V tých zošitoch sú linky na zdrojový zošit. Teda aj s cestou. Vy keď si urobíte kópiu toho celého adresára so zdrojom, aj so súbormi, tak to fungovať nebude, lebo tie súbory stále obsahujú cestu k pôvodnému umiestneniu. Tiež som si to neuvedomil, že tie Vaše súbory z prílohy tiež obsahujú Vašu pôvodnú cestu. Riešením na vyskúšanie, bez rizika poškodenia origo súborov je, že si urobíte zálohu celého origo adresára, z ktorej nebudete nič otvárať ani meniť. Makro vložíte do pôvodného origo adresára, kde sú aj správne cesty k linkom a spustíte. Pôvodnú origo verziu všetkých súborov dostanete, ak tú zálohu nakopčíte na pôvodné miesto. Bez rizika.
Vyskúšajte toto, rozbalte to priamo do C:\ nech sa nám zhodujú foldre. Zmente hodnoty v hlavnom, použite makro. Zatvorte hlavný a zmente mu názov napr. na "zdroj2.xlsm". Premiestnite ABC niekde inde napr. na kľúč, a otvorte. Hodnota bude zmenená. Ale link bude na pôvodný súbor v C:\, len ho nenájde a nechá poslednú známu hodnotu (ak nieje nastavený Excel inak).

A nebola by k tomu lepšia jedna spoločná procedúra, ako kopčiť X obdobných ?
Sub Filtruj(Stlp As Integer)
Dim Radku As Long

Radku = Cells(Rows.Count, 1).End(xlUp).Row - 4
Radku = Radku + (Radku = 0 And 1)
Application.ScreenUpdating = False

If Columns(Stlp + 1).Hidden Then
Cells(5, Stlp + 1).AutoFilter
Columns(4).Resize(, 41).Hidden = False
Cells(4, 2).ClearContents
Else
Columns(4).Resize(, 41).Hidden = True
Columns(Stlp).Hidden = False
Cells(4, 2).Value = Cells(5, Stlp + 1).Value
Cells(5, Stlp + 1).Resize(Radku).AutoFilter Field:=1, Criteria1:=1
End If

Application.ScreenUpdating = True
End Sub

Private Sub BMSMainstream_Click()
Filtruj 4
End Sub
Private Sub BMSTransfer_Click()
Filtruj 6
End Sub
Private Sub BMLMainstream_Click()
Filtruj 8
End Sub
Private Sub BMLTransfer_Click()
Filtruj 10
End Sub
Private Sub MCW_Click()
Filtruj 12
End Sub
Private Sub SCW_Click()
Filtruj 14
End Sub
Private Sub FrontGril_Click()
Filtruj 16
End Sub
Private Sub BottomFrame_Click()
Filtruj 18
End Sub
Private Sub RadiantPanel_Click()
Filtruj 20
End Sub
Private Sub CoverAirOutlet_Click()
Filtruj 22
End Sub
Private Sub TV_Click()
Filtruj 24
End Sub
Private Sub GSI_Click()
Filtruj 26
End Sub
Private Sub Emura2_Click()
Filtruj 28
End Sub
Private Sub Stylish_Click()
Filtruj 30
End Sub
Private Sub SC1_Click()
Filtruj 32
End Sub
Private Sub SC2_Click()
Filtruj 34
End Sub
Private Sub SC3_Click()
Filtruj 36
End Sub
Private Sub SC4_Click()
Filtruj 38
End Sub
Private Sub SC5_Click()
Filtruj 40
End Sub
Private Sub SC6_Click()
Filtruj 42
End Sub

Keď bude chuť a súvislých pár hodín času (čo min do konca budúceho týždňa nehrozí), tak by som mohol urobiť taký rozbor, kde bude ukázaný postup a čo ktorá časť vzorcov robí a čo dáva za medzivýsledky. Ale nesľubujem. Prípadne si toto vlákno niekam uložte, a občas ho omrknite ak sem nechodíte často...

XLSM sa nedá priložiť priamo. Treba ho zabaliť do ZIP.

Aha, tak Vy potrebujete napr. preniesť súbory inam, ale aby mali aktualizované dáta zo zdroja? Lebo inak budú mať pôvodné hodnoty. No tak to asi jedine makro. Vyskúšajte niečo takéto.
Vytvorí novú inštanciu Excelu na pozadí, v nej postupne otvorí všetky súbory xls, xlsx, xlsm v adresári s týmto súborom, uloží ich, a zavrie. Teda budú mať aktualizované hodnoty.

Skúšajte to VÝHRADNE na kópii súborov v nejakom skúšobnom adresári ! Až kým nebude isté, že je to to, čo potrebujete.

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse