Új hozzászólás Aktív témák
-
Delila_1
veterán
válasz prodrakan #2900 üzenetére
Próbáld ezzel:
Sub IndexFuggveny()
Dim UresSor As Long
UresSor = Range("K1").End(xlDown).Row + 1
Do
If Cells(UresSor, "A") = "" Then UresSor = UresSor + 1
Loop Until Cells(UresSor, "A") <> "" And Cells(UresSor, "K") = ""
Range("C" & UresSor & ":C5000") = "=INDEX('\\Hubudr99102dat\mf\MF3\" _
& "FEMSZERK_TERMELES\Fémszerkezet\2015.08.01_Komponens_és_szekrény_gyártás\" _
& "Tervező\2017\[Tervező_2017.xlsm]Planner'!$I$" & UresSor & ":$I$5000;HOL.VAN(A" & UresSor & "," _
& "'\\Hubudr99102dat\mf\MF3\FEMSZERK_TERMELES\Fémszerkezet\2015.08.01_Komponens_és_szekrény_gyártás\" _
& "Tervező\2017\[Tervező_2017.xlsm]Planner'!$A$" & UresSor & ":$A$5000,0))"
End SubA Range("K1").End(xlDown).Row a K1 cellán nyomott Ctrl+le művelet VBA-s megfelelője. Ez az első, üres cella fölötti sor értékét adja meg. 1-et hozzáadva megkapjuk az első üres cella sorát a K oszlopban.
Ha ez a sor az A oszlopban üres, addig növeljük a sorszámot, míg igaz nem lesz, hogy a K üres, az A nem.
Ide, ill. innen az ötezredik sorba írjuk be (nálam a C oszlopba, te majd átírod) a hosszú képletedet, egy lépésben.Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
válasz prodrakan #2904 üzenetére
Feltettem a 2 fájlt.
Mindkét füzet legyen nyitva, az Excel1.xlsm-be kitettem egy gombot a makró indításához.
Érdemes az alsó sorból indulni, és addig keresni felfelé a G oszlopban az üres cellákat, míg fel nem jutunk a 3-as sorban lévő címsor fölé.
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
válasz prodrakan #2906 üzenetére
Beírtam a makróba, hogy amíg dolgozik, a státuszsorban megjelenik a "Nyugi, dolgozom" szöveg. Kevés adatnál nem látszik, olyan gyorsan eltűnik.
Pontosítanod kellene, melyik oszlopot akarod még figyeltetni, mit figyeljen a makró, és mit tegyen.
Sub Kikeres()
Dim UresSor As Long, WSInnen As Worksheet, WSIde As Worksheet
Dim TalalSor, usor As Long, WF As WorksheetFunction
Set WSInnen = Workbooks("Excel2.xlsx").Sheets("Munka1")
Set WSIde = Workbooks("Excel1.xlsm").Sheets("Munka1")
Set WF = Application.WorksheetFunction
WSIde.Activate
Application.StatusBar = "Nyugi, dolgozom"
Application.ScreenUpdating = False
usor = Range("G" & Rows.Count).End(xlUp).Row
Do
UresSor = Range("G" & usor).End(xlUp).Row - 1
If UresSor < 3 Then
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub
End If
If Cells(UresSor, "A") <> "" Then
On Error Resume Next
TalalSor = WF.Match(Cells(UresSor, "A"), WSInnen.Columns(1), 0)
Cells(UresSor, "G") = WSInnen.Cells(TalalSor, "I")
On Error GoTo 0
Else: usor = UresSor - 1
End If
Loop Until Cells(UresSor, "A") <> "" And Cells(UresSor, "G") = ""
End SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
válasz prodrakan #2908 üzenetére
Feltettem az újabb verzió-t.
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
válasz prodrakan #2910 üzenetére
Feltöltöttem az Excel1-et. Mindhárom oszlopban töröltem az utolsó sorokat, azokat is kitölti a makró.
A lefagyásnak valami helyi oka lehet, nálam nem fordul elő.
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
válasz prodrakan #2912 üzenetére
Annál a módszernél, amit írtál (első üres sortól kezdje bemásolni a másik 2 fájlból az adatokat), túl sok a hibalehetőség. Most megírtam úgy, hogy az első adattól, a 4. sortól fusson végig egy For-Next ciklussal addig a sorig, ahol az A oszlopban megtalálja az utolsó adatot.
Az útvonal értékét a makró 10. sorában kell átírni, és esetlegesen új értéket adni neki a 36. sor előtt.
[ Szerkesztve ]
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
válasz prodrakan #2914 üzenetére
A makrót írd át.
Sub Parosit()
Dim usor As Long, sor As Long, utvonal As String
Dim WB1 As Workbook, WB2 As Workbook, WB3 As Workbook
Dim WF As WorksheetFunction, TalalSor As Long
Dim kezd As Long, vegez As Long
Set WB1 = Workbooks("Excel1.xlsm")
Set WF = Application.WorksheetFunction
utvonal = "F:\Eadat\Excel fórumok\PH\"
kezd = Application.InputBox("Add meg a kezdő hét sorszámát", "Kezdő hét", , , , , , 1)
vegez = Application.InputBox("Add meg a záró hét sorszámát", "Záró hét", , , , , , 1)
kezd = WF.Match(kezd, Columns(2), 0)
vegez = WF.Match(vegez, Columns(2), 1)
Application.StatusBar = "Nyugi, dolgozom"
Application.ScreenUpdating = False
usor = WB1.Sheets("Munka1").Range("A" & Rows.Count).End(xlUp).Row
'Excel2-ből I oszlop az Excel1 G-be
Workbooks.Open Filename:=utvonal & "Excel2.xlsx"
Set WB2 = Workbooks("Excel2.xlsx")
WB1.Activate
For sor = kezd To vegez
If Cells(sor, "G") = "" And Cells(sor, "A") <> "" Then
TalalSor = WF.Match(Cells(sor, "A"), WB2.Sheets("Munka1").Columns(1), 0)
Cells(sor, "G") = WB2.Sheets("Munka1").Cells(TalalSor, "I")
End If
If Cells(sor, "J") = "" And Cells(sor, "A") <> "" Then
TalalSor = WF.Match(Cells(sor, "A"), WB2.Sheets("Munka1").Columns(1), 0)
Cells(sor, "J") = WB2.Sheets("Munka1").Cells(TalalSor, "J")
End If
Next
WB2.Close False
'Excel3-ból I oszlop az Excel1 K-ba
Workbooks.Open Filename:=utvonal & "Excel3.xlsx"
Set WB3 = Workbooks("Excel3.xlsx")
WB1.Activate
For sor = kezd To vegez
If Cells(sor, "K") = "" And Cells(sor, "A") <> "" Then
TalalSor = WF.Match(Cells(sor, "A"), WB3.Sheets("Munka1").Columns(1), 0)
Cells(sor, "K") = WB3.Sheets("Munka1").Cells(TalalSor, "I")
End If
Next
WB3.Close False
Application.StatusBar = False
Application.ScreenUpdating = True
End SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
Új hozzászólás Aktív témák
- Konzolokról KULTURÁLT módon
- Háztartási gépek
- Vodafone-ra áttért Digi Mobilosok
- Elektromos autók - motorok
- Politika
- Szünetmentes tápegységek (UPS)
- sziku69: Fűzzük össze a szavakat :)
- Amazfit Balance - ár-érték egyensúly
- D1Rect: Nagy "hülyétkapokazapróktól" topik
- Az ár/érték bajnok Galaxy A52-re is kész a One UI 6.1
- További aktív témák...
- Eladó ASUS RTX 3070 TUF GAMING!
- Garanciális ! be quiet! Pure Rock 2 Processzor hűtő
- EVGA GeForce GTX 1080 Ti FTW3 GAMING 11GB GDDR5X 352bit (11G-P4-6696-KR) Videokártya
- Üzletből,garanciával, HP Spectre 14" X360, i7-1165G7/16GB RAM/512GB SSD/4K OLED TOUCH/Toll
- G.SKILL FlareX 64GB (4x16GB) DDR4 Quad-channel kiszerelés
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: Alpha Laptopszerviz Kft.
Város: Pécs