Tak len tak zo srandy...
Na požiadanie som urobil ešte inú verziu predošlého súboru.
Pr.
Sub Zapis()
Dim R As Long, i As Long, D(), S() As String
With ActiveSheet
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R = 0 Then Exit Sub
D = .Cells(2, 3).Resize(R, 8).Value2
ReDim S(1 To R, 1 To 1)
For i = 1 To R
Select Case D(i, 8)
Case "Dutch": S(i, 1) = "Factuur " & D(i, 1) & " - EUR" & D(i, 3) & ", verlopen op " & Format(D(i, 5), "d-m-yyyy") & Chr(10) & "Betaallink: https://payments.invoice.com/" & D(i, 2)
Case "English": S(i, 1) = "Invoice " & D(i, 1) & " - EUR" & D(i, 3) & ", due on " & Format(D(i, 5), "d-m-yyyy") & Chr(10) & "Payment link: https://payments.invoice.com/" & D(i, 2)
Case Else: S(i, 1) = "ERROR_LANGUAGE"
End Select
Next i
.Cells(2, 11).Resize(R).Value2 = S
End With
End Sub
?
Napr. takto. Kód si dajte do formu, kde máte vytvorený ListBox1.
Dim S(), Pocet As Long
Private Sub UserForm_Initialize()
Dim FSO As Object, fsoAdresar As Object
Const Cesta = "C:\2017\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoAdresar = FSO.getFolder(Cesta)
Call ZoznamSuborov(fsoAdresar)
Set FSO = Nothing: Set fsoAdresar = Nothing
If Pocet > 0 Then ListBox1.List = S
End Sub
Sub ZoznamSuborov(ByRef fsoAdresar As Object)
Dim fsoSubor As Object, fsoPodAdresar As Object, PocS As Long
With fsoAdresar
PocS = .Files.Count
If PocS > 0 Then
ReDim Preserve S(1 To Pocet + PocS)
For Each fsoSubor In .Files
Pocet = Pocet + 1
S(Pocet) = fsoSubor.Path
Next fsoSubor
End If
For Each fsoPodAdresar In .subFolders
Call ZoznamSuborov(fsoPodAdresar)
Next fsoPodAdresar
End With
Set fsoPodAdresar = Nothing: Set fsoSubor = Nothing
End Sub
Pridávam radšej aj prílohu...
Zopár príkladov...
Na karte "Informace o autě" som pridal položku "Měna", kde si volíte Kč / €. Formátovanie meny sa prepne všade. Nahradil som aj nešťastné formátovanie "rrrr", ktoré je iba v CZ Exceli, a v SK Exceli znefunkční kontinkenčné tabuľky.
Príloha je asi veľká, neberie mi ju server, tak tu je aj na Google Drive
Blbé bude pri zoradení, ak bude u viac položiek rovnaký dátum.
Ak budú položky oddelené riadkom alebo prvá ďalšia neprázdna bunka v A od nájdenej položky je už druhá položka, tak potom napr. takto. Ale ako to bude náročné pri 3000 položkách. No neviem neviem. To možno skôr nejaký pomocný stĺpec.
Nastavte si iba primerane veľký rozsah v OBLAST_OZN.
Veď sme ho dali do wbOld, tak cez neho skúsit.
Ja keď chcem vyskúšať Váš kód na zistenie počtu inštancií, tak si to musím upraviť na x64 verziu:
#If Win64 Then
Public Declare PtrSafe Function GetDesktopWindow Lib "User32" () As LongLong
Public Declare PtrSafe Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As LongLong, ByVal hWnd2 As LongLong, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongLong
#Else
#If VBA7 Then
Public Declare PtrSafe Function GetDesktopWindow Lib "User32" () As Long
Public Declare PtrSafe Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
#Else
Public Declare Function GetDesktopWindow Lib "User32" () As Long
Public Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
#End If
#End If
'Public Declare PtrSafe Function GetDesktopWindow Lib "User32" () As Long
'Public Declare PtrSafe Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Function ExcelInstances() As Long
#If Win64 Then
Dim hWndDesk As LongLong
Dim hWndXL As LongLong
#Else
Dim hWndDesk As Long
Dim hWndXL As Long
#End If
'Získat popisovac na plochu
hWndDesk = GetDesktopWindow
Do
'Získat další okno aplikace Excel
hWndXL = FindWindowEx(hWndDesk, hWndXL, "XLMAIN", vbNullString)
'Když jsme dostali jeden, zvýšit pocet
If hWndXL > 0 Then
ExcelInstances = ExcelInstances + 1
End If
'Loop, dokud jsme je našli všechny
Loop Until hWndXL = 0
End Function
a to mi vracia počet okien (aj to zvýšených o 5, teda jedna inštancia s jedným súborom vráti číslo 6), nie inštancií.
Našiel som zaujímavý minikód, ktorý skutočne zistí počet inštancií:
Function CountExcelInstances()
strComputer = "."
Set objWMI = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set proc = objWMI.ExecQuery("Select * from Win32_Process Where Name = 'Excel.exe'")
CountExcelInstances = proc.Count
Set proc = Nothing
Set objWMI = Nothing
End Function
Bohužiaľ, ale prepnutie na inú inštanciu Excelu, nevyvolá v predošlej inštancii metódu Deactivate. Takže aj tak prd z toho...
Skúšané na Office 2016 Pro SK x64, Win10 x64 Pro SK
Vy ste ako môj svokor. Keď ma minule navigoval tak asi takto:
"Vidíš tú modrú budovu vpravo? Pred ňou je svetelná križovatka, vidíš ju? Tak tam nebudeme odbočovať."
...po chvíli...
"Tam ako stojí ten autobus, na zastávke. Vidíš ? Za ním je odbočovací pruh vpravo."
...Prejdem za tú zástavku, hádžem smerovku doprava, a ...
"Tu ale my nebudeme odbočovať ?!"
Tak Vy podávate presne rovnaké zbytočné, mylné a nezmyselné informácie.
Príklad:
- Ja Vám vysvetľujem, čo je priorita (poradie) testov, a Vy :
"Takto by to malo vyzerať pri splnení všetkých podmienok"
Ale veď vo Vašom prípade bude vždy splnená LEN JEDNA podmienka !!!
- Mätúce použitie slov vo vetách:
"je nula z A2"
Matematický výraz "je nula z X" neexistuje. Buď je niečo nula, alebo je niečo X.
- Neodpovedanie na otázku, niekoľkokrát zopakovanú :
Dajte si tam tento vzorec:
=IF(B2<C2;0;IF(AND(B2>=C2;D2<C2);A2/2;IF(B2=D2;A2;IF(B2>D2;A2*(1+((B2-D2)/(B2/100)/100));"A KURŇA !!!"))))
=KDYŽ(B2<C2;0;KDYŽ(A(B2>=C2;D2<C2);A2/2;KDYŽ(B2=D2;A2;KDYŽ(B2>D2;A2*(1+((B2-D2)/(B2/100)/100));"A KURŇA !!!"))))
a B2 zmente na 169.
Trpezlivosť je obmedzená. Snažte sa o 200% viac, potom si 2x prečítajte svoj napísaný text, či Vám slová dávajú zmysel.
Veď ide o tak triviálnu vec, zapísať vzorec s IF/KDYŽ ... len treba presné info ...
Tak potom by mohol pomôcť takýto test
Private Sub Workbook_Deactivate()
Dim wbAct As Workbook, wbOld As Workbook
Set wbOld = ThisWorkbook 'Ak potrebujete niečo robiť s Vašim pôvodným zošitom
Set wbAct = ActiveWorkbook 'Aktívny zošit (chránený zošit sa nepriradí)
If wbAct Is Nothing Then Set wbAct = Application.ActiveProtectedViewWindow.Workbook 'Ak je chránený zošit, treba urobiť priradenie inak
wbOld.Worksheets("Log").Cells(wbOld.Worksheets("Log").Rows.Count, 1).End(xlUp).Offset(1).Value = wbAct.Name 'Logovanie mena aktívneho zošitu, do aktívneho listu vo Vašom zošite
Set wbOld = Nothing
Set wbAct = Nothing
End Sub
Ale asi to nebude fungovať pri deaktivácii na inú inštanciu. To som neskúšal.
Fakt neviem, čo s Vami.
má byť rozpätie medzi bunkami C2 a D2 a len kontrola hodnoty medzi týmito bunkami k bunke B2
Ono sa to asi v Chránenom zobrazení otvorí v druhej inštancii Excelu, čistý tip. Čo potrebujete robiť v tej Deactivate ? Či sa to nedá len preskočiť v On Error, alebo treba podúmať nad API, alebo či nemôžete proste Chránené zobrazenie úplne vypnúť.
Tak som Vám nakoniec prerobil všetky vzorce a def. názvy.
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.