Hirdetés
- gban: Ingyen kellene, de tegnapra
- droidic: Windows 11 önállóság nélküli világ: a kontroll új korszaka
- Luck Dragon: Asszociációs játék. :)
- sziku69: Fűzzük össze a szavakat :)
- sh4d0w: Kalózkodás. Kalózkodás?
- GoodSpeed: Ennél jobb Windows 7 Aero Skin nem igen van Windows 11-re (WindowBlinds 11)
- Pajac: Hámozott narancs
- sziku69: Szólánc.
- Brogyi: CTEK akkumulátor töltő és másolatai
- GoodSpeed: 24 éves a Windows XP! Nézzen ki úgy a Windows 11 mint az XP?
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
- WoW avagy World of Warcraft -=MMORPG=-
- Tőzsde és gazdaság
- Mini PC
- iPhone topik
- Samsung Galaxy S23 Ultra - non plus ultra
- gban: Ingyen kellene, de tegnapra
- Vivo X200 Pro - a kétszázát!
- Azonnali informatikai kérdések órája
- Fotók, videók mobillal
- Multimédiás / PC-s hangfalszettek (2.0, 2.1, 5.1)
- További aktív témák...
- Apple MacBook Pro 13" 2019 256/8GB Akku:40 ciklus! Magyar
- Gamer PC-Számítógép! Csere-Beszámítás! I5 12600K / RTX 3070Ti / 32GB DDR5 / 512 SSD!
- Honor 200 256GB,Újszerű,Dobozával, 12 hónap garanciával
- Keresek BOSE / JABRA / SENNHEISER / Bowers szervizest
- ÁRGARANCIA!Épített KomPhone Ryzen 7 5700X 16/32/64GB RAM RX 7600 8GB GAMER PC termékbeszámítással
Állásajánlatok
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest
Cég: NetGo.hu Kft.
Város: Gödöllő