Hirdetés
-
PROHARDVER!
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
-
válasz
bozsozso
#9681
üzenetére
No mindegy, majd kipróbálod, aztán ha valamit módosítani kell, akkor módosítva lesz...

Private Sub CommandButton1_Click()
'elválasztó-karakter a CSV fájlokon belül
Const MYDELIMITER = ";"
'hol találhatóak a CSV fájlok
Const MYPATH = "D:\fire\csvs_path\"
'melyik munkalapra legyenek bemásolva az adatok
Dim DestWB As Worksheet
Set DestWB = Worksheets("Munka2")
'a megadott munkalap melyik cellájától kerüljenek be az adatok
Dim DestRange As Range
Set DestRange = DestWB.Range("A1")
Dim MyStr As String
Dim MyStrs() As String
'meg kell adni, milyen terméket keressünk a CSV fájlok-ban és OK gomb
'Cancel gombbal megszakítható a művelet
UserChange = InputBox("Mit keressünk? (kis- és nagybetű nem számít...)", "Keresés...")
If Len(UserChange) > 0 Then
Application.ScreenUpdating = False
'kiválasszuk a megadott munkalapot
DestWB.Select
'töröljük annak teljes tartalmát
DestWB.UsedRange.Clear
DestRange.Select
MyRowCount = 0
MyFname = Dir(MYPATH & "*.csv")
Do While Len(MyFname) > 0
MyFnum = FreeFile
Open MYPATH & MyFname For Input As MyFnum
While Not EOF(MyFnum)
Line Input #MyFnum, MyStr
MyStrs = Split(MyStr, MYDELIMITER)
'vizsgáljuk, hogy a CSV fájl adott sorában, utolsó eleme után van-e még elválasztókarakter avagy sem
If Right(MyStr, 1) = MYDELIMITER Then
MyCount = UBound(MyStrs())
Else: MyCount = UBound(MyStrs()) + 1
End If
'a MyStrs(0) indexével adjuk meg, hogy a CSV fájlon belül, hányadik elem a termék neve
'első->0, második->1, harmadik->2 stb stb
If UCase(MyStrs(0)) = UCase(UserChange) Then
For i = 0 To MyCount - 1
ActiveCell.Offset(MyRowCount, i).Value = MyStrs(i)
Next i
MyRowCount = MyRowCount + 1
End If
Wend
Close MyFnum
MyFname = Dir()
Loop
Application.ScreenUpdating = True
'ha nem találtunk egyetlen megadott nevű terméket sem, arról értesítést adunk
If MyRowCount = 0 Then MsgBox "A megadott termék nem található az átvizsgált CSV fájlokban.", vbInformation
End If
Set DestWB = Nothing
Set DestRange = Nothing
End Sub -
Új hozzászólás Aktív témák
- Xbox Series X 1 TB + kontroller 6 hó garancia, számlával!
- 15,6" Dell Latitude laptopok: E5550, E5570, 5590, 5500, 5501, 5510, 5520 / SZÁMLA + GARANCIA
- iPhone 13 mini 128GB Green -1 ÉV GARANCIA -Kártyafüggetlen, MS3896, 95% Akkumulátor
- REFURBISHED és ÚJ - DELL Universal Dock UD22
- Nagyakkus! Dell Latitude 5430 i7-1255U 16GB 512GB 14" FHD 1 év garancia
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest
Cég: NetGo.hu Kft.
Város: Gödöllő

Fferi50

