[excel] Import macro

[excel] Import macro 10.06.2008. u 14:06 · pre 223 meseca #1

Potreban mi je import macro sa sledecim karakteristikama:
1. Import svih .txt fajlova iz odredjenog direktorijuma. Ne postoji "odvajac" za kolone, ali su sve kolone u tim fajlovima na istom rastojanju.
2. Stvaranje nove kolone u importovanom dokumentu, gde bi celije imale vrednost naziva .txt fajla iz kog se importuje. Naravno celije u toj koloni bi bile ispunjene do poslednjeg popunjenog reda koji definise sadrzina .txt file-a.
3. Spajanje u jedan "veliki" .xls novostvorenih, zasebnih .xls fajlova koji nose ime po orginalu .txt .

Mislim da bih se okrpio sa znanjem za uzimanje svih txt fajlova iz dir-a i import istih, sigurno mi je problem stavka 2. i deo stavke 3.

Re: [excel] Import macro 11.06.2008. u 14:08 · pre 223 meseca #2

Ok, ajd da probamo da resimo problem.

Dodaj novi modul i ubaci ovaj kod. Obrati paznju da putanja, broj kolona, sirine kolona treba da azuriras u ovom kodu.

Code:

Option Explicit

Public FolderPath As String
Public SearchMask As String
Public ImportPosition As String
Public NumberOfColumns As Long

Public Sub UveziPodatke()
Dim l As Long
Dim i As Long
Dim j As Long
Dim s As String
    ' Application.ScreenUpdating = False
    FolderPath = "C:\Excel Test"
    SearchMask = "*.txt"
    ImportPosition = "A"
    NumberOfColumns = 4

    With Application.FileSearch
        .LookIn = FolderPath
        .Filename = SearchMask
        If .Execute() > 0 Then
            l = 1
            For i = 1 To .FoundFiles.Count
                s = (ImportFile(.FoundFiles(i), "A" & l, IIf(l = 1, 1, 2)))
                Range("A" & l).Select
                ActiveCell.Offset(0, NumberOfColumns).Range("A1:A" & Range(s).Rows.Count).Select
                Selection.FormulaR1C1 = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(FolderPath) - 1)
                l = l + Range(s).Rows.Count
            Next i
        End If
    End With
    'Application.ScreenUpdating = True

End Sub

Public Function ImportFile(FN As String, Lok As String, StartR As Long) As String
Dim s As String
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & FN, Destination:=Range(Lok))
        .Name = "tab_" & Right(FN, Len(FN) - Len(FolderPath) - 1)
        s = .Name
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = StartR
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
' Uneti onoliko 1 (General tip) koliko se kolona unosi
' odnosno sirine fiksnih kolona
        .TextFileColumnDataTypes = Array(1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(8, 8, 8)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    ImportFile = s
End Function

Ako treba mozemo i da diskutujemo o ovom kodu. Mozda je nesto moglo i jednostavnije,
no ovo je najbrze sto sam mogao da smislim. Napravi par fajlova sa po 4 kolone fiksnih
sirina po 8 karaktera (prve 3 su po 8, poslednja nije bitna). U svakom fajlu neka prvi red
bude naslovni red - on ce se uvoziti samo iz prvog .txt fajla.

Pozdrav

Re: [excel] Import macro 04.07.2008. u 09:27 · pre 223 meseca #3

Bug u ovoj liniji koda:
With Application.FileSearch <= object doesn't support this action

excel 2007

..ako si i dalje voljan.

Forum kao aplikacija na telefonu

Srodne teme