Új hozzászólás Aktív témák

• Fire/SOUL/CD félisten

  #48730

  #48728 jerry311

  2022-03-22 18:07:09

  Új Válasz

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  

  Fire/SOUL/CD

  félisten

  #48728 jerry311

  Az itt található adatokat vettem alapul. Létrehoztam belőle 3 db CSV fájlt, az első maradt érintetlen, a 2.-ban lecseréltem az összes DOWN státuszt UP-ra, a 3.-ban meg lecseréltem az összes UP-t FIRE-UP-ra, nyilván azért, hogy több státusz is legyen.

  A kód futtatásának ez lett az eredménye:
  

  A Module1-be másolandó kód (és fontos, hogy modul-ba kerüljön!)

  'Fire/SOUL/CD - 2022

Public Sub Fire_CSV_Process()

'mappa, amelyben a CSV fájlok találhatóak
Const MYCSVFOLDER = "C:\CSVs\"
'CSV elválasztó karakter megadása
Const MYDELIMITER = ","
'Ha igaz, akkor nem dolgozza fel a fejlécet
Const CSVFILEUSEHEADER = True
'A munkalap ezen cellájától illeszti be az összesítést
Const TABLETOPLEFTCORNER = "A1"

Dim MyWorksheetName As String
Dim MyCurrCSVFname As String
Dim MyFileNumber As Long
Dim MyCurrStr As String
Dim CSVLineNdx As Long
Dim MyStrs() As String
Dim MyRowNdx As Long
Dim NameFieldStartRange, IDFieldStartRange As Range
Dim FindNameFieldRange, FindIDFieldRange As Range
Dim FindNameRange, FindIDRange As Range

'ellenőrizzük, hogy a megadott mappa létezik-e, ha nem, akkor nem fut le a kód
If Dir(MYCSVFOLDER, vbDirectory) = "" Then
MsgBox "A megadott mappa [" & MYCSVFOLDER & "] nem létezik." & vbCrLf & "Adj meg egy létező mappát..."
Exit Sub
End If

'létrehozunk egy új munkalapot (itt másodpercre pontos idő lesz a nevében,
'ezért nem ellenőrzöm, hogy létezik-e már adott néven munkalap)
MyWorksheetName = "Ősszesítés_" & Format(Now, "yymmdd_hhmmss")
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyWorksheetName
Worksheets(MyWorksheetName).Activate

Application.ScreenUpdating = False

MyRowNdx = 0

Set NameFieldStartRange = Range(TABLETOPLEFTCORNER)
Set IDFieldStartRange = Range(TABLETOPLEFTCORNER).Offset(0, 1)

'megadott mappában végigszaladunk az összes CSV fájlon
MyCurrCSVFname = Dir(MYCSVFOLDER & "*.CSV")
Do While Len(MyCurrCSVFname) > 0
MyFileNumber = FreeFile
Open MYCSVFOLDER & MyCurrCSVFname For Input As MyFileNumber
CSVLineNdx = 0
'CSV fájlt egyenként, soronként feldolgozzuk
While Not EOF(MyFileNumber)
Line Input #MyFileNumber, MyCurrStr
If CSVFILEUSEHEADER = True And CSVLineNdx = 0 Then
Line Input #MyFileNumber, MyCurrStr
CSVLineNdx = 1
End If
'ha üres sor van benne, azt kihagyjuk
If MyCurrStr <> "" Then
'legeslső adat esetén nincs mit összehasonlítani
If MyRowNdx = 0 Then
MyStrs = Split(MyCurrStr, MYDELIMITER)
Range(TABLETOPLEFTCORNER).Offset(0 + MyRowNdx, 0) = MyStrs(0)
Range(TABLETOPLEFTCORNER).Offset(0 + MyRowNdx, 1) = MyStrs(1)
Range(TABLETOPLEFTCORNER).Offset(0 + MyRowNdx, 2) = MyStrs(2)
Else
'meghatározzuk a keresési tartományokat
MyStrs = Split(MyCurrStr, MYDELIMITER)
Set FindNameFieldRange = Range(NameFieldStartRange.Address & ":" & Chr(NameFieldStartRange.Column + &H40) & MyRowNdx)
Set FindIDFieldRange = Range(IDFieldStartRange.Address & ":" & Chr(IDFieldStartRange.Column + &H40) & MyRowNdx)

'keresünk egyező adatokat
Set FindNameRange = FindNameFieldRange.Find(what:=MyStrs(0), LookIn:=xlValues, lookat:=xlWhole)
Set FindIDRange = FindIDFieldRange.Find(what:=MyStrs(1), LookIn:=xlValues, lookat:=xlWhole)

'ha van egyezés, akkor a találati tartomány sorában megkeressük az első üres cellát
'és beleírjuk a megfelelő adatot
If Not FindNameRange Is Nothing And Not FindIDRange Is Nothing Then
Cells(FindNameRange.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Value = MyStrs(2)
MyRowNdx = MyRowNdx - 1
Else
Range(TABLETOPLEFTCORNER).Offset(0 + MyRowNdx, 0) = MyStrs(0)
Range(TABLETOPLEFTCORNER).Offset(0 + MyRowNdx, 1) = MyStrs(1)
Range(TABLETOPLEFTCORNER).Offset(0 + MyRowNdx, 2) = MyStrs(2)
End If
End If
MyRowNdx = MyRowNdx + 1
End If
Wend
Close MyFileNumber

MyCurrCSVFname = Dir()

Loop

Application.ScreenUpdating = True

End Sub

  Teszteld, remélem jó lesz.

  [ Módosította: radi8tor ]

Új hozzászólás Aktív témák