Import pliku tekstowego


Przykładowe makro do wczytania pliku tekstowego do excela ;)

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As String, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As String, ByVal cchWideChar As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function GetOpenFileNameW Lib "comdlg32.dll" (pOpenfilename As OPENFILENAME) As Long


Public Sub ImportStartNT1()
Dim op As OPENFILENAME
Dim res As Long
Dim txt As String, wide As String
Clear
op.hwndOwner = 0
op.hInstance = 0
txt = "Pliki SPBU" + Chr(0) + "SPBU*.*" + Chr(0) + _
"Wszystkie pliki" + Chr(0) + "*.*" + Chr(0) + Chr(0)

op.lpstrFilter = String(256, 0)
MultiByteToWideChar 0, 0, txt, Len(txt), op.lpstrFilter, 256

op.nMaxFile = 256
op.lpstrFile = String(256, 0)
op.lStructSize = LenB(op)

res = GetOpenFileNameW(op)
If (res = 0) Then Exit Sub

txt = String(256, 0)
WideCharToMultiByte 0, 0, op.lpstrFile, 256, txt, 256, "", 0
txt = Left(txt, InStr(1, txt, Chr(0)) - 1)

ImportNT1 (txt)

End Sub


Sub Clear()
Worksheets("Arkusz1").Range("A:A").Clear
Worksheets("Arkusz1").Range("B:B").Clear
Worksheets("Arkusz1").Range("C:C").Clear
Worksheets("Arkusz1").Range("D:D").Clear
Worksheets("Arkusz1").Range("E:E").Clear
Worksheets("Arkusz1").Range("F:F").Clear
Worksheets("Arkusz1").Range("G:G").Clear
Worksheets("Arkusz1").Range("H:H").Clear
Worksheets("Arkusz1").Range("I:I").Clear

End Sub

Sub FillValue(idr As Integer, idc As Integer, dt As String, st As Boolean)

Dim c As Range
Set c = Sheets("Arkusz1").Cells(idr, idc)
c.BorderAround 1, xlThin, xlColorIndexAutomatic, clblack
c.Value2 = dt

If st Then
'naglowek
If idr = 1 Then
c.Interior.ColorIndex = 7
c.Font.ColorIndex = 27
c.Font.FontStyle = "Bold"

Else
c.Interior.ColorIndex = 3
c.Font.ColorIndex = 27
c.Font.FontStyle = "Normal"
End If


Else
c.Interior.ColorIndex = xlColorIndexAutomatic
End If

End Sub


Sub ImportNT1(fn As String)

On Error GoTo End_ImportNT1

Open fn For Input As #1

Dim c As Range

Dim strA As String
Dim k_nr As String
Dim naz As String
Dim kwo As String
Dim z As String
Dim tmp As String
Dim tmps As String
Dim SumRow As Boolean

Dim rw As Integer

Dim id_row As Integer
Dim ile As Integer

id_row = 1
ile = 0
'zapis naglowka
FillValue 1, 1, "Ktonr.", True
FillValue 1, 2, "Kontenbezeichnung", True
FillValue 1, 3, "Saldo", True
FillValue 1, 4, "nicht faellig", True
FillValue 1, 5, "bis 30 Tage", True
FillValue 1, 6, "31 - 60 Tage", True
FillValue 1, 7, "61 - 90 Tage", True
FillValue 1, 8, "91 - 120 Tage", True
FillValue 1, 9, "ueber 120 Tage", True

Do While Not EOF(1) '*** petla po pliku tekstowym
Line Input #1, strA
'konto
k_nr = Trim(Left(strA, 9))
If (IsNumeric(k_nr)) Then
strA = Right(strA, Len(strA) - 9)
id_row = id_row + 1
ile = ile + 1

'nazwa
SumRow = False

naz = LTrim(RTrim(Left(strA, 20)))
strA = Right(strA, Len(strA) - 20)

tmp1 = InStr(1, naz, "=")
If tmp1 > 0 Then
tmp = Right(naz, Len(naz) - tmp1)
naz = Trim(tmp)
End If

If StrComp(naz, "Forderungskonto") = 0 Then
SumRow = True
End If

'zapis numeru
FillValue id_row, 1, k_nr, SumRow

'kolor numeru
FillValue id_row, 2, naz, SumRow

'kwota i
rw = 0
Do While Len(strA) >= 14
kwo = Left(strA, 14)
kwo = LTrim(RTrim(kwo))

strA = Right(strA, Len(strA) - 14)

tmp1 = InStr(1, kwo, ".")
If tmp1 <> 0 Then
tmp = Left(kwo, tmp1 - 1)
tmps = Right(kwo, Len(kwo) - tmp1)
kwo = tmp + tmps
End If
tmp1 = InStr(1, kwo, ",")
If tmp1 <> 0 Then
tmp = Left(kwo, tmp1 - 1)
tmps = Right(kwo, Len(kwo) - tmp1)
kwo = tmp + "." + tmps
End If

If (Len(strA) >= 1) Then
z = Left(strA, 1)
strA = Right(strA, Len(strA) - 1)
If z = "-" Then
kwo = "-" + kwo
End If
End If
FillValue id_row, 3 + rw, kwo, SumRow
rw = rw + 1
Loop
End If
If SumRow Then
SumRow = False
id_row = id_row + 1
End If
Loop

End_ImportNT1:
Close #1
Worksheets("Arkusz1").Columns("A:Z").AutoFit
Worksheets("Arkusz1").Activate
MsgBox "Import zakonczony. Zaimportowano " + CStr(ile) + " wierszy"

End Sub