text file import
This macro import some kind of text file into Excel woorkbook
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