Příspěvky uživatele

Ten 3. požadovaný výsledok, máte nesprávny :)

Zvládne to aj hromadnú zmenu.

1. Prečo spúšťate makro s názvom "Makro1" z modulu "Module1"? To je iba zabudnuté skúšobné makro z rekordéru makier, keď som si chcel nahrať ako vyzerajú parametre. Skutočné makro,"Worksheet_Calculate", ako som spomínal, je predsa v module listu "List4".
2. A to "Worksheet_Calculate" Vy nijako nespúšťate, to sa robí samé.
3. Čokoľvek kamkoľvek kopírujete, musíte si overiť, či sedia napr. rozsahy, adresy, názvy objektov a pod. Neviem, čo Vám tam robí chybu, a nechce sa mi skúmať. Prihoďte reálny súbor, v ktorom to nefunguje, a označte, zdrojové data, a na ďalší list dajte ako má presne vyzerať výsledok. Možno keď bude čas ...

Maticový vzorec (je v Definovanom názve),a potom len VLOOKUP/SVYHLEDAT. Mne sa nepáčia tie rozsahy čo tam máte. Niekde milión riadkov, inde 3000, potom 5500 alebo 3300, či ako to tam bolo...
Seznam_měřidel - som nastavil na 3000 dátových riadkov, aj rám aj Podmienený formát
Čeká na kalibraci - som nastavil na 1000 dátových riadkov, aj rám aj Podmienené formátovanie, odstránil som Overenie dát lebo v tomto liste je výpis, nemáte tam nič meniť, a zmenil formát posledných stĺpcov s dátumami.

Okrem VLOOKUP/SVYHLEDAT sa to dá aj tak, že by matica vracala nie číslo meradla, ale číslo riadku, a potom by sa ten VLOOKUP() vymenil za INDEX(). Možno to bude rýchlejšie, viď Čeká na kalibraci (2).

Jedine udalostné makro:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Jmeno As String
If Not Intersect(Cells(3, 2), Target) Is Nothing Then
Application.EnableEvents = False
On Error Resume Next
Jmeno = WorksheetFunction.VLookup(Cells(3, 2), wsData.ListObjects("tblHesla").DataBodyRange, 2, False)
Cells(3, 2) = IIf(Err.Number = 0, Jmeno, Empty)
Application.EnableEvents = True
End If
End Sub

Ten kód predsa musíte dať do listu "List4", lebo ten sa prepočítava, a pri tomto prepočítaní sa aktualizuje Textové pole v liste Hárok1, teda zmente tento riadok na :
With Hárok1.Shapes("txtPoleSpolu").TextFrame2.TextRange
Tieto riadky tam niesú potrebné ak nemeníte nikde farbu:
Dim text As String
.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
a 2x
.Fill.ForeColor.RGB = RGB(0, 0, 0)

Možno tak jedine udalostné makro ("Calculate"), vzorec tam nemôže byť.

No máte tam v S1
12Kč / likometr
nemá to byť
12Kč / kilometr
?

Hmm, no je pravda, že je to trochu svojsky riešené. To nieje výtka. Ja by som si vyberal napr aj mená z výberového zoznamu (Overenie dát) bez prepínania listu. Ak je potrebné veľmi často zadávať doteraz nepoužité mená, tak VBA formulárom. Každopádne teraz na to nemám chuť

Len 2 poznámky:
-To mazanie čo spomínate (a to len tipujem, neskúmal som) je možno tým, že nepoužívate premennú na uchovanie hodnoty, ale neustále hľadáte prvý voľný riadok v A. Ten nájde, ale ak zapíšete do A novú hodnotu, v ďalšom riadku kódu chcete písať do B, ale ako prvá prázdna bunka v A už nieje tá, ako pred chvíľou, lebo ste ju zapísal. A bunky treba zapísať naraz, nie po jednej.
-A druhá poznámka s tým súvisí, tie makrá by sa mali prepracovať. Dajú sa urobiť oveľa jednoduchšie, napr. mazanie hodnôt
Sub VYMAZ()
With ActiveSheet
.Unprotect "0000"
.Shapes(Application.Caller).TopLeftCell.Offset(0, -10).Resize(, 10).ClearContents
.Protect "0000"
End With
End Sub
alebo to pridávanie žiadosti:
Sub PRIDAJ_DO_ZOZNAMU_ZIADOSTI()
With ActiveSheet
If .Range("H2").Value = 47 Or .Range("I2").Value = 47 Or .Range("J2").Value = 47 Then Exit Sub
.Unprotect "0000"
.Cells(19, 1).End(xlDown).Offset(1, 0).Resize(, 9).Value = Array(.Cells(9, 2), .Cells(9, 3), .Cells(9, 6), .Cells(12, 2), .Cells(12, 3), .Cells(12, 6), .Cells(7, 2), .Cells(7, 9), .Cells(9, 9))
.Cells(2, 1).Resize(, 10).Formula = Array(0, 0, 0, "=C2/2", 0, "=E2/2", 0, 47, 47, 47)
.Protect "0000"
End With
End Sub
atď...

A opravte si tú kilometrovú sadzbu

(opravte, nie upravte)

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.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje