Hirdetés
- sziku69: Fűzzük össze a szavakat :)
- Luck Dragon: MárkaLánc
- Luck Dragon: Asszociációs játék. :)
- bambano: A sor végén
- Brogyi: CTEK akkumulátor töltő és másolatai
- sziku69: Szólánc.
- Sub-ZeRo: Euro Truck Simulator 2 & American Truck Simulator 1 (esetleg 2 majd, ha lesz) :)
- btz: Internet fejlesztés országosan!
- sh4d0w: Árnyékos sarok
- Parci: Milyen mosógépet vegyek?
Aktív témák
-
-
picsu
csendes tag
Hát be kell valjjam nem megy ez nekem.....
A kiszedés működik ahogy megcsináltad de a fordítottja nem....
Mindig olyan verziót tudtam csak csinálni ahol a cél pont a forrás volt....
Lapa ne légy kegyetlen....
Sub export()
Dim elso, masodik, harmadik, negyedik, otodik, hatodik, hetedik As String
Dim fold As FileDialog
Dim foldrv As Variant
Dim fso As Object
Dim fajllista As FileSearch
Dim fajllistaindex As Long
Dim forras, cel As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cel = ActiveWindow.Caption
Set fold = Application.FileDialog(msoFileDialogFolderPicker)
With fold
If .Show = -1 Then
foldrv = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set fajllista = Application.FileSearch
With fajllista
.NewSearch
.LookIn = foldrv
.Filename = ''*.xls''
.SearchSubFolders = False
If .Execute > 0 Then
For fajllistaindex = 1 To .FoundFiles.Count
'MsgBox .FoundFiles(fajllistaindex)
Workbooks.Open Filename:=.FoundFiles(fajllistaindex)
forras = ActiveWindow.Caption
'
With Workbooks(forras).Sheets(1)
Workbooks(cel).Sheets(1).Cells(fajllistaindex + 5, 1) = Workbooks(forras).Sheets(1).Cells(3, 2)
End With
'(fajllistaindex, 1) = workbooks(
Application.DisplayAlerts = False
Workbooks(forras).Close, savechanges = true
Application.DisplayAlerts = True
'''=[Book1.xls]Sheet1!R1C1''
'''=['' & .FoundFiles(fajllistaindex) & ''![;]](//cdn.rios.hu/dl/s/v1.gif)
Sheet1!R1C1''
Next fajllistaindex
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
MsgBox ''Na ez is megvan mégsincs este... Összesen '' & fajllistaindex & '' fájlból importáltunk adatokat.'', vbInformation + vbOKOnly, ''Komisszióadatok importálása befejeződött''
End Sub -
lapa
veterán
nem tudom mi olyan bonyolult ebben. már a múltkor is sikerült megküzdened vele. itt ugyanúgy kell eljárni azzal a különbséggel, hogy nem a céltáblába (amiben a makró van) raksz bele valamit a MAKRÓ ÁLTAL megnyitott fájlokból, hanem az éppen megnyitott fájlba írsz bele valamit, majd bezárod. annyi a különbség az előzőhöz képest, hogy a ''workbooks(???).close, savechanges:=true'' sor kell bele asszem. de ezt makrorögzítővel le tudod lesni. szmájlik helyett sztem olvasd el újra az ottani dolgot, meg nézd meg a makrót.
-
shev7
veterán
[link] Ezzel a peldaprogrammal konnyen boldogulhatsz, csak vedd ki a felesleges reszeket (pl a sorbarendezes em kell neked) Ha megkapod a fileok listajat, akkor egyesevel megnyitod oket, es vegrehajtod a szukseges valtoztatasokat. (ne felejtsd el bezarni, mert 700 nyitott filelal a win nehezen fog boldogulni. Azt, hogy hogy tudsz file-t megnyitni bezarni a legkonnyebben ugy tudod meg, hogy rogzitesz egy makrot.
-
lapa
veterán
így nekem sem sikerült, ahogy a legelején írtam is. mondom ne szenvedj vele szerintem.
esetleg egy ilyen sor helyett: Workbooks(cel).Sheets(1).Cells(fajllistaindex, 1) = Workbooks(forras).Sheets(1).Cells(1, 1)
írhatsz:
with Workbooks(forras).Sheets(1)
Workbooks(cel).Sheets(1).Cells(fajllistaindex, 1) = .Cells(3, 11) + .cells(4, 11) + .cells(5,11).... + .cells(16,11)
end with
még talán ez a szimplibb... -
-
Jester01
veterán
Ez elég egyszerû feladat, bár a gépnek is el fog tartani mire megnyitogatja a 12000 fáljt...
Sajna most egyetlen elérhetõ gépen sincs excel, szóval nem tudom megcsinálni neked.
De ilyesmi lenne:
Dim fso, f, f1, i
Set fso = CreateObject(''Scripting.FileSystemObject'')
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
i = 0
For Each f1 in fc
i = i + 1
Workbooks.Open f1.Name
ThisWorkbook.ActiveSheet.Cells(0, i) = Cells(x, y)
ActiveWorkbook.Close
Next
Az x,y a fix cella ahonnan olvasni akarsz. Ez így vszg nem mûködik, de kiindulási alapnak sztm jó.
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Sheet1!R1C1''
Aktív témák
- Óra topik
- sziku69: Fűzzük össze a szavakat :)
- VR topik (Oculus Rift, stb.)
- S.T.A.L.K.E.R. 2: Heart of Chornobyl
- Huawei Watch GT 6 és GT 6 Pro duplateszt
- Samsung Galaxy S25 Ultra - titán keret, acélos teljesítmény
- Luck Dragon: MárkaLánc
- Milyen videókártyát?
- MW2 - MW3 játékosok baráti köre
- Gaming notebook topik
- További aktív témák...
- ASIC Miner HW/SW/OC Optimalizálás (NerdQAxe++, Nerd Octaxe, Bitaxe, stb.)
- Apple IPhone 14 pro 256gb
- Jura Impressa F70 Automata kávégép 6 hónap Garancia Beszámítás Házhozszállítás
- DeLonghi Magnifica Automata kávégép 6 hónap Garancia Beszámítás Házhozszállítás
- Apple iPhone 15 PRO MAX 256 GB White Titanium 1 év Garancia Beszámítás Házhozszállítás
- HP Omen 80G8E9 - 27" IPS - UHD 4K - 144Hz 1ms - NVIDIA G-Sync - FreeSync - HDR 400 - USB Type-C
- HIBÁTLAN iPhone 13 mini 128GB Blue -1 ÉV GARANCIA - Kártyafüggetlen, MS3846, 94% Akkumulátor
- ÚJ OMEN Transcend 14 - 14"2.8K OLED 120Hz - Ultra 7 155H - 16GB - 1TB - RTX 4060 - Win11 - 3 év gari
- 365 NAPRA RÉSZLETRE BANKMNETES KAMATMENTES , GAMER PC ,LAPTOPOK , GAMER SZÉKEK , GAMER MONITOROK
- Lejárt a gyártói garancia? Mi tovább támogatjuk az IT infrádat!
Állásajánlatok
Cég: NetGo.hu Kft.
Város: Gödöllő
Cég: Promenade Publishing House Kft.
Város: Budapest