Příspěvky uživatele

Ahoj, používám podobný kód níže uvedeného(funkčnost stejná) k plnění Array.
Aby následné procedury fungovaly správně potřebuji čísla srovnat od nejmenšího po největší.

Děkuji za pomoc

Sub Test1()

Set MyArrList = CreateObject("System.Collections.ArrayList")

MyArrList.Add "1"
MyArrList.Add "5"
MyArrList.Add "11"
MyArrList.Add "16"
MyArrList.Add "7"
MyArrList.Add "3"
MyArrList.Add "9"
MyArrList.Add "2"

For Each Name In MyArrList
Debug.Print Name
Next

End Sub

Zkus tohle, snad je to ono.

Set IdAddressList = CreateObject("System.Collections.ArrayList")

tmp_Addrss_In = Selection.Address
tmp_Addrss = Array("$", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U")

For Each tA In tmp_Addrss
tmp_Addrss_In = Replace(tmp_Addrss_In, tA, "")
Next tA

tmp_Addrss_Out = tmp_Addrss_In

Dim TextStrng As String
Dim Result() As String
Dim DisplayText As String
TextStrng = tmp_Addrss_Out
Result = Split(TextStrng, ",")
For i = LBound(Result()) To UBound(Result())
IdAddressList.Add Result(i)
Next i

For Each Name In IdAddressList
Debug.Print Name
Next

V kartě > Elektrotrend > Nastavení lze upravit adresářovou strukturu a následně simulovat chování.

Je to trochu oholené, funkcí už je hodně a bylo by to nepřehledné.

Podstatné zůstalo.

Dobrý den,

napsal jsem si funkci pro ověřování existence složky na disku.
Cesty jsou generované excelem a vše je plně funkčí.

Poprosil bych, zdy by někdo koukl a případně předal nějaké připomínky.

Děkuji.

Function KontrolaExistenceSlozkyZakazky()

Dim cell As Range
Dim rng As Range

'Definování Aktivního řádku
R = ActiveCell.Row

'Proměné
VyrobniCisloRozvadece = Cells(R, 1)
ZakaznikAkce = Cells(R, 2)
AktualniRok = Format(Now, "yyyy")
ZakazkoveCislo = Mid(VyrobniCisloRozvadece, 1, 4)

OdstranMezeruZakaznikAkce = WorksheetFunction.Trim(ZakaznikAkce)
CistyTvarZakaznikAkce = KontrolaZnaku("" & OdstranMezeruZakaznikAkce & "")

Sheets("Config").Visible = True

ZvolenyAdresar = Workbooks(ZakazkovaKniha).Sheets("Config").Range("route_disc")

Sheets("Temp").Visible = True
Application.ScreenUpdating = False
Workbooks(ZakazkovaKniha).Sheets("Temp").Activate
ActiveSheet.Range("F1").Select

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ZvolenyAdresar)
Set fc = f.SubFolders
For Each f1 In fc
polozka = f1.Name

ActiveCell.Value = polozka
ActiveCell.Offset(1, 0).Select

Next
Range("F:F").Find("System Volume Information").Delete Shift:=xlUp

PosledniPlnyRadek = Cells(Rows.Count, "F").End(xlUp).Row + 1 ' Ve sloupci F

Set rng = Workbooks(ZakazkovaKniha).Sheets("Temp").Range("F1:F" & PosledniPlnyRadek & "")

Workbooks(ZakazkovaKniha).Sheets("Kniha zakázek").Activate

For Each cell In rng

UmisteniSlozkyZakazkyArr = ZvolenyAdresar & cell.Value & "\" & ZakazkoveCislo & "-" & CistyTvarZakaznikAkce & ""

If Len(Dir(UmisteniSlozkyZakazkyArr, vbDirectory)) = 0 Then
'Nenalezena
Else
KontrolaExistenceSlozkyZakazky = UmisteniSlozkyZakazkyArr
'MsgBox (KontrolaExistenceSlozkyZakazky)

Exit For

End If

If cell.Value = "" Then
MsgBox ("Složka nenalezena")
End If

Next cell

Sheets("Config").Visible = False
Sheets("Temp").Visible = False
Workbooks(ZakazkovaKniha).Sheets("Kniha zakázek").Activate
Application.ScreenUpdating = True

End Function

Ochrany jsem řešil takto.

Čísla se zapisují do sloupce a není problém, že by došlo místo.

Hodnota First zažím nepřesáhla 2 ciferné číslo, naní pro to ani předpoklad.

Number = Application.InputBox(Prompt:="Zadejte číslo ", Type:=1)
If Number = "" Then Exit Sub
First = Application.InputBox("Zadejte počáteční číslo", Default:="01", Type:=1)
If First = "" Then Exit Sub
Last = Application.InputBox("Zadejte koncové číslo", Type:=1)
If Last = "" Then Exit Sub

For i = First To Last
ActiveCell.Value = Number & " " & Format(i, "00")
ActiveCell.Offset(1, 0).Select
Next i

Přesně to jsem potřeboval, moc děkuji.

Dobrý den,

chtěl bych používat níže uvedené makro pro generování číselného řetězece. Bohužel výstup je např. 1234 1 a já bych potřeboval 1234 01. Předem děkuji za každou radu.

Dim Number As String
Dim First As String
Dim Last As String

Number = InputBox("zadej číslo řady")
First = InputBox("zadej první číslo")
Last = InputBox("zadej poslední číslo")
For i = First To Last
ActiveCell.Value = Number & " " & i
ActiveCell.Offset(1, 0).Select
Next i

Problém to není. Nejlépe za užití plánovač úloh Windows.
Počítač běží stále, nebo zapínáte každý den?

Omlouvám se, pokud jsem se chybně vyjídřil.

Problém je to, že nevím jak načíst data z aktivní oblasti a říct aby červená pole překopírovala.

Dobrý den,

potřeboval bych z vybrané oblasti kopírovat 1 a 3-6 sloupec a tyto sloupce následně vložit do druhého sešitu od pole B3.

Předem děkuji za veškeré rady.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje