-
Fototrend
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
n1nja
tag
Sziasztok.
Segítséget szeretnék kérni.
Adott egy táblázat a következő oszlopokkal:
Gép, Idő, TervAzon, Terv.
Alaphelyzetben gép szerinti ABC sorrend rendezés van, azon belül a Terv-ek vannak meghatározott sorrendben.
Szeretném az egészet időrendi sorrendbe rakni, úgy, hogy a gépnevek ne essenek szét (maradjanak meg a csoportok), megtartva a tervek sorrendjét. (TervAzon szerint is jó lenne rendezni)Próbáltam így is, úgy is, de nem jutottam egyről a kettőre.
Teszek fel egy képet:
bal oldali táblázat az eredeti, középső a hibás rendezéssel és a jobb oldali, amit szeretnék megvalósítani.Köszönöm a hozzászólásokat előre is.
Üdv.
Gábor -
n1nja
tag
válasz poffsoft #36040 üzenetére
akár
(gépenként az első dátumot kimenti egy tömb-be, majd a tömböt növekvő sorrendbe rendezi és az időpont új sorszámát beírja gépenként a sorting no. oszlopba)
nem szép, de működikPrivate Sub CommandButton1_Click()
Dim currv As Integer
Dim csere As Date
Dim i, j, k, rowcount As Integer
Dim currmachine As String
Dim tomb(1 To 145) As Date
range("R2").Value = "Sorting no."
mint = range("C3").Value
maxt = range("C3").Value
currmachine = " "
rowcount = range("A3", range("A3").End(xlDown)).Rows.Count
Cells(3, 25).Value = rowcount
j = 0
For i = 1 To rowcount
If currmachine <> Cells(i + 2, 1) Then
currmachine = Cells(i + 2, 1)
j = j + 1
tomb(j) = Cells(i + 2, 3)
End If
Next i
For i = 1 To j - 1
For k = i + 1 To j
If tomb(i) > tomb(k) Then
csere = tomb(i)
tomb(i) = tomb(k)
tomb(k) = csere
End If
Next k
Next i
currmachine = " "
For i = 1 To rowcount
If currmachine <> Cells(i + 2, 1) Then
For k = 1 To j
If Cells(i + 2, 3) = tomb(k) Then
currv = k
End If
Next k
End If
Cells(i + 2, 18).Value = currv
Next i
End Sub[ Szerkesztve ]
Új hozzászólás Aktív témák
- Samsung Galaxy S24 - nos, Exynos
- Vodafone otthoni szolgáltatások (TV, internet, telefon)
- Milyen légkondit a lakásba?
- Trollok komolyan
- Luck Dragon: Asszociációs játék. :)
- Fejhallgató erősítő és DAC topik
- Építő/felújító topik
- Redmi Note 12 Pro - nem tolták túl
- gban: Ingyen kellene, de tegnapra
- sziku69: Fűzzük össze a szavakat :)
- További aktív témák...
- 3db eredeti PC játékok
- Régi PC Játékok - Rome Total War/Barbarian Invasion/SpellForce/Simcity 4
- Eredeti Windows 10, Windows 11, Office Akció: Office 2021, Office 2019, Office 2016 csak Retail
- Total War: WARHAMMER II - The Warden & The Paunch (DLC) Epic Games Key GLOBAL
- World of Warcraft 15th Anniversary Collectors Edition - BONTATLAN - shipper barna kartonban - ÚJ