Note: The other languages of the website are Google-translated. Back to English

Ինչպե՞ս թղթապանակից բազմաթիվ տեքստային ֆայլեր ներմուծել մեկ աշխատանքային թերթի մեջ:

Դեպքերի համար այստեղ դուք ունեք բազմաթիվ տեքստային ֆայլեր ունեցող պանակ, այն, ինչ ցանկանում եք անել, այս տեքստային ֆայլերը ներմուծել մեկ աշխատանքային թերթի մեջ, ինչպես ցույց է տրված ստորև նշված նկարից: Փոխանակ տեքստային ֆայլերը մեկ առ մեկ պատճենելու, կա՞ն հնարքներ տեքստային ֆայլերը մեկ թղթապանակից մեկ թերթի մեջ արագ ներմուծելու համար:

Ներմուծեք բազմաթիվ տեքստային ֆայլեր մեկ թղթապանակից մեկ թերթիկի մեջ VBA- ով

Excel- ի համար Kutools- ով ներմուծեք տեքստային ֆայլ ակտիվ բջիջ լավ գաղափար 3


Ահա VBA կոդը կարող է օգնել ձեզ ներմուծել բոլոր տեքստային ֆայլերը մեկ հատուկ թղթապանակից նոր թերթի մեջ:

1. Միացրեք աշխատանքային գիրքը, որը ցանկանում եք ներմուծել տեքստային ֆայլեր և սեղմել Alt + F11 հնարավորություն տալու ստեղները Microsoft Visual Basic հավելվածների համար պատուհան.

2: սեղմեք Տեղադրել > Մոդուլներ, պատճենեք և տեղադրեք ներքևում գտնվող VBA կոդ ՝ Մոդուլներ պատուհան.

VBA. Ներմուծեք բազմաթիվ տեքստային ֆայլեր մեկ թղթապանակից մեկ թերթ

Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

3. Մամուլ F5 երկխոսություն ցուցադրելու համար և ընտրեք պանակ, որը պարունակում է տեքստային ֆայլեր, որոնք ցանկանում եք ներմուծել: Տեսեք,
փաստաթուղթը ներմուծում է տեքստային ֆայլեր 1 թղթապանակից

4: սեղմեք OK, Այնուհետև տեքստային ֆայլերը ներմուծվում են ակտիվ աշխատանքային գրքույկ ՝ որպես առանձին նոր թերթ:
փաստաթուղթը ներմուծում է տեքստային ֆայլեր 2 թղթապանակից


Եթե ​​ցանկանում եք մեկ տեքստային ֆայլ ներմուծել որոշակի բջիջ կամ տիրույթ, կարող եք դիմել Excel- ի համար նախատեսված գործիքներ'S Տեղադրեք ֆայլը կուրսորում կոմունալ.

Excel- ի համար նախատեսված գործիքներ, ավելի քան 300 հարմար գործառույթներ, ավելի հեշտացնում է ձեր գործերը: 

Այն բանից հետո անվճար տեղադրում Excel- ի համար նախատեսված գործիքներ, խնդրում ենք վարվել ինչպես ստորև ՝

1. Ընտրեք բջիջ, որը ցանկանում եք ներմուծել տեքստային ֆայլը և կտտացնել Kutools Plus > Ներմուծման արտահանման > Տեղադրեք ֆայլը կուրսորում, Տեսեք,
փաստաթուղթը ներմուծում է տեքստային ֆայլեր 3 թղթապանակից

2. Դրանից հետո դուրս է գալիս երկխոսություն, կտտացրեք Թերթել ցուցադրելու համար Ընտրեք ֆայլ բջջի կուրսորի դիրքի երկխոսության մեջ տեղադրելու համար հաջորդը ընտրեք Տեքստային ֆայլեր բացվող ցուցակից, ապա ընտրեք տեքստային ֆայլը, որը ցանկանում եք ներմուծել: Տեսեք,
փաստաթուղթը ներմուծում է տեքստային ֆայլեր 4 թղթապանակից

3: սեղմեք բաց > Ok, և նշված տեքստի ֆայլը տեղադրվել է կուրսորի դիրքում, տես նկարի նկարը.
փաստաթուղթը ներմուծում է տեքստային ֆայլեր 5 թղթապանակից


Գրասենյակի արտադրողականության լավագույն գործիքները

Excel-ի համար Kutools-ը լուծում է ձեր խնդիրների մեծ մասը և բարձրացնում ձեր արտադրողականությունը 80%-ով

  • Վերաօգտագործել: Արագ տեղադրեք բարդ բանաձևեր, գծապատկերներ և այն ամենը, ինչ դուք նախկինում օգտագործել եք. Ryածկագրել բջիջները գաղտնաբառով; Ստեղծեք փոստային ցուցակ և նամակներ ուղարկել ...
  • Super Formula Bar (հեշտությամբ խմբագրեք տեքստի և բանաձևի բազմաթիվ տողեր); Ընթերցանության դասավորությունը (հեշտությամբ կարդալ և խմբագրել մեծ թվով բջիջներ); Տեղադրել ֆիլտրացված տիրույթում...
  • Միաձուլել բջիջները / տողերը / սյունակները առանց տվյալների կորստի. Պառակտված բջիջների պարունակությունը; Միավորել կրկնօրինակ տողերը / սյունակները... Կանխել կրկնօրինակ բջիջները; Համեմատեք միջակայքերը...
  • Ընտրեք Կրկնօրինակ կամ Եզակի Շարքեր; Ընտրեք դատարկ շարքեր (բոլոր բջիջները դատարկ են); Super Find և Fuzzy Find շատ աշխատանքային գրքույկներում; Պատահական ընտրություն ...
  • Actշգրիտ պատճեն Բազմաթիվ բջիջներ ՝ առանց բանաձևի հղումը փոխելու; Ավտոմատ ստեղծեք հղումներ դեպի մի քանի թերթեր; Տեղադրեք փամփուշտներ, Տուփեր և ավելին ...
  • Քաղվածք տեքստ, Տեքստ ավելացնել, հեռացնել ըստ դիրքի, Հեռացնել տարածությունը; Ստեղծել և տպել էջային ենթագոտիներ; Փոխարկել բջիջների բովանդակության և մեկնաբանությունների միջև...
  • Սուպեր զտիչ (պահպանել և կիրառել ֆիլտրի սխեմաները այլ թերթերի վրա); Ընդլայնված տեսակավորում ըստ ամիս / շաբաթ / օր, հաճախականություն և ավելին; Հատուկ զտիչ համարձակ, շեղատառով ...
  • Միավորել աշխատանքային տետրերը և աշխատանքային թերթերը; Միավորել աղյուսակները ՝ հիմնված հիմնական սյունակների վրա; Տվյալները բաժանեք մի քանի թերթերի; Խմբաքանակի փոխակերպում xls, xlsx և PDF...
  • Ավելի քան 300 հզոր հատկություններ. Աջակցում է Office / Excel 2007-2021 և 365: Աջակցում է բոլոր լեզուներին: Հեշտ տեղակայում ձեր ձեռնարկությունում կամ կազմակերպությունում: Ամբողջական հնարավորություններ 30-օրյա անվճար փորձարկում: 60-օրյա գումարի վերադարձի երաշխիք:
kte էջանիշը 201905

Office Tab- ը Tabbed ինտերֆեյսը բերում է Office, և ձեր աշխատանքը շատ ավելի դյուրին դարձրեք

  • Միացնել ներդիրներով խմբագրումը և ընթերցումը Word, Excel, PowerPoint- ով, Հրատարակիչ, Access, Visio և Project:
  • Բացեք և ստեղծեք բազմաթիվ փաստաթղթեր նույն պատուհանի նոր ներդիրներում, այլ ոչ թե նոր պատուհաններում:
  • Բարձրացնում է ձեր արտադրողականությունը 50%-ով և նվազեցնում մկնիկի հարյուրավոր սեղմումները ձեզ համար ամեն օր:
officetab ներքևում
Տեսակավորել մեկնաբանությունները ըստ
մեկնաբանություններ (46)
Գնահատված 4- ը 5- ից դուրս է · 1 վարկանիշ
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ենթաթեստ ()
― ԹարմացնելովExtendoffice6 / 7 / 2016
Dim xWb որպես աշխատանքային գրքույկ
Dim xToBook As Workbook-ը
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Dim xFiles որպես նոր հավաքածու
Dim I As Long
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = "Ընտրեք թղթապանակ [Kutools for Excel]"
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Եթե ​​Right(xStrPath, 1) <> "\" Ապա xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & «*.txt»)
Եթե ​​xFile = "" Ապա
MsgBox «Ֆայլեր չեն գտնվել», vbInformation, «Kutools for Excel»
Ելք ենթ
Վերջ: Եթե
Do while xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Հանգույց
Սահմանել xToBook = This Workbook
Եթե ​​xFiles.Count > 0 Ապա
For I = 1 To xFiles.Count
Սահմանել xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Պատճենել հետո՝=xToBook.Sheets(xToBook.Sheets.Count)
Ս.թ. սխալի Ռեզյումե Next
ActiveSheet.Name = xWb.Name
Սխալի դեպքում GoTo 0
xWb.Փակել կեղծ
հաջորդ
Վերջ: Եթե
Վերջ Sub

այս կոդը օգնում է, բայց ես ուզում եմ

ներդիր, կիսակետ, բացատ ճիշտ է, թե ինչպես դա անել, խնդրում եմ օգնեք ինձ
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ցանկանու՞մ եք պահպանել տարածությունը (սահմանազատիչները) տեքստային ֆայլերը թերթերի վերածելուց հետո:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
դա նույնպես իմ խնդիրն է, այս կոդը ճիշտ է: բայց տեքստային ֆայլերը excel-ի փոխարկելուց հետո այն չի պահում սահմանազատողները:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Կարո՞ղ եք վերբեռնել տեքստային ֆայլը և այն արդյունքը, որը ցանկանում եք ինձ համար:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ես նույն խնդիրն ունեմ։ Txt ֆայլերը բոլորը առանձին թերթերում են, և կոդը անտեսում է երկու սյունակների միջև եղած տարածությունը
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, Des և PB Rama Murty, ստորև բերված կոդը կարող է տվյալները բաժանել սյունակների՝ հիմնված տարածության կամ ներդիրի վրա՝ տեքստային ֆայլը թերթիկներ ներմուծելիս: Դուք կարող եք փորձել:

Sub ImportTextToExcel()
― ԹարմացնելովExtendoffice20180911
Dim xWb որպես աշխատանքային գրքույկ
Dim xToBook As Workbook-ը
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Dim xFiles որպես նոր հավաքածու
Dim I As Long
Dim xIntRow այնքան երկար
Dim xFNum, xFArr այնքան երկար
Dim xStrValue որպես տող
Dim xRg որպես տիրույթ
Dim xArr
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = "Ընտրեք թղթապանակ [Kutools for Excel]"
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Եթե ​​Right(xStrPath, 1) <> "\" Ապա xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & «*.txt»)
Եթե ​​xFile = "" Ապա
MsgBox «Ֆայլեր չեն գտնվել», vbInformation, «Kutools for Excel»
Ելք ենթ
Վերջ: Եթե
Do while xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Հանգույց
Սահմանել xToBook = This Workbook
Ս.թ. սխալի Ռեզյումե Next
Դիմում. ScreenUpdating = Սուտ է
Եթե ​​xFiles.Count > 0 Ապա

For I = 1 To xFiles.Count
Սահմանել xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Պատճենել հետո՝=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Փակել կեղծ
xIntRow = ActiveCell.CurrentRegion.Rows.Count
xFNum = 1-ից դեպի xIntRow
Սահմանել xRg = ActiveSheet.Range («A» և xFNum)
xArr = Split (xRg.Text, " ")
Եթե ​​UBound(xArr) > 0 Ապա
xFArr-ի համար = 0 Դեպի UBound (xArr)
Եթե ​​xArr(xFArr) <> "" Ապա
xRg.Value = xArr(xFArr)
Սահմանել xRg = xRg.Offset(ColumnOffset:=1)
Վերջ: Եթե
հաջորդ
Վերջ: Եթե
հաջորդ
հաջորդ
Վերջ: Եթե
Դիմում. ScreenUpdating = ueիշտ է
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ինչ փոփոխություններ են անհրաժեշտ, եթե ցանկանում եք տվյալները բաժանել սյունակների՝ ստորակետերի վրա հիմնված
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ի՞նչ փոփոխություններ պետք է արվեն, եթե ինձ անհրաժեշտ են ամբողջական տվյալներ ստորակետերի վրա հիմնված սյունակներում:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ես օգտագործել եմ սա, և այն աշխատում է, բայց ես կցանկանայի, որ այդ ամենը պահվեր մեկ թերթիկի վրա, քանի որ յուրաքանչյուր թերթը նույն տեղեկատվությունն է, դրանք պարզապես տեղեկամատյանների ֆայլեր են ամեն օր:
այնպես որ ես պետք է համատեղեմ
թղթապանակի բոլոր տարրերը մեկ թերթիկ
Sub ImportCSVsWithReference()
«Թարմացում ըստ կուտոուլսների Excel20151214-ի համար
Dim xWb որպես աշխատանքային գրքույկ
Dim xToBook As Workbook-ը
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Dim xFiles որպես նոր հավաքածու
Dim I As Long
Dim xIntRow այնքան երկար
Dim xFNum, xFArr այնքան երկար
Dim xStrValue որպես տող
Dim xRg որպես տիրույթ
Dim xArr
Սխալի դեպքում GoTo ErrHandler
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = "Ընտրեք թղթապանակ [Kutools for Excel]"
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Եթե ​​Right(xStrPath, 1) <> "\" Ապա xStrPath = xStrPath & "\"
Սահմանել xSht = ThisWorkbook.ActiveSheet
Եթե ​​MsgBox («Մաքրել առկա թերթիկը ներմուծումից առաջ», vbYesNo, «Kutools for Excel») = vbYes Այնուհետեւ xSht.UsedRange.Clear
Դիմում. ScreenUpdating = Սուտ է
xFile = Dir(xStrPath & "\" & "*.log")
Do while xFile <> ""
Սահմանել xWb = Workbooks.Open (xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Փակել կեղծ
xFile = Ռեժ
Հանգույց
Դիմում. ScreenUpdating = ueիշտ է
Ելք ենթ
ErrHandler:
MsgBox «txt ֆայլեր չկան», , «Excel-ի համար նախատեսված գործիքներ»
Վերջ Sub

և այս մեկը, որը յուրաքանչյուր սյունակին dd-ի բացատներ է օգտագործում

Sub ImportTextToExcel()
― ԹարմացնելովExtendoffice20180911
Dim xWb որպես աշխատանքային գրքույկ
Dim xToBook As Workbook-ը
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Dim xFiles որպես նոր հավաքածու
Dim I As Long
Dim xIntRow այնքան երկար
Dim xFNum, xFArr այնքան երկար
Dim xStrValue որպես տող
Dim xRg որպես տիրույթ
Dim xArr
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = "Ընտրեք թղթապանակ [Kutools for Excel]"
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Եթե ​​Right(xStrPath, 1) <> "\" Ապա xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & «*.txt»)
Եթե ​​xFile = "" Ապա
MsgBox «Ֆայլեր չեն գտնվել», vbInformation, «Kutools for Excel»
Ելք ենթ
Վերջ: Եթե
Do while xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Հանգույց
Սահմանել xToBook = This Workbook
Ս.թ. սխալի Ռեզյումե Next
Դիմում. ScreenUpdating = Սուտ է
Եթե ​​xFiles.Count > 0 Ապա

For I = 1 To xFiles.Count
Սահմանել xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Պատճենել հետո՝=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Փակել կեղծ
xIntRow = ActiveCell.CurrentRegion.Rows.Count
xFNum = 1-ից դեպի xIntRow
Սահմանել xRg = ActiveSheet.Range («A» և xFNum)
xArr = Split (xRg.Text, " ")
Եթե ​​UBound(xArr) > 0 Ապա
xFArr-ի համար = 0 Դեպի UBound (xArr)
Եթե ​​xArr(xFArr) <> "" Ապա
xRg.Value = xArr(xFArr)
Սահմանել xRg = xRg.Offset(ColumnOffset:=1)
Վերջ: Եթե
հաջորդ
Վերջ: Եթե
հաջորդ
հաջորդ
Վերջ: Եթե
Դիմում. ScreenUpdating = ueիշտ է
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ինչպե՞ս անել, եթե իմ Txt ֆայլը սահմանազատված է ստորակետով:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Դուք կարող եք օգտագործել Find and Replace fuctuon՝ ստորակետը նախ բացատով փոխարինելու համար, և կիրառել վերը նշված եղանակներից մեկը՝ այն Excel ֆայլի փոխարկելու համար:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Կոդում սա փոխելու տարբերակ չկա՞։ Ես պետք է դա անեի 130 ֆայլով
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Նույն հարցը
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Նրանց համար, ովքեր դեռ օգնության կարիք ունեն այս հարցում, փոխարինեք xArr = Split(xRg.Text, " ") xArr = Split(xRg.Text, ","):
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Երբ ես գործարկում եմ մոդուլը, ինչպես տրված է, այն ավելացնում է յուրաքանչյուր .txt ֆայլ որպես նոր թերթ, ոչ թե որպես նոր տող գոյություն ունեցող թերթին: Կա՞ արդյոք դրան հասնելու միջոց յուրաքանչյուր .txt ֆայլի համար նոր թերթիկների փոխարեն:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ուզում եք միավորել ամբողջ տեքստային ֆայլը մեկ թերթիկի մեջ:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Այո, սա այն է, ինչ ես նույնպես ուզում եմ:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, Դավինդեր, կարող եք փորձել ստորև vba կոդը:
Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
        xWb.Close False
        xFile = Dir
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no txt files", , "Kutools for Excel"
End Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Կոդը շատ օգտակար է, դա միակ ծածկագիրն է, որը ես գտել եմ, որը մեծ քանակությամբ ստանում է txt ֆայլեր այն շտկումը, որն ինձ անհրաժեշտ է դրա վրա, այն է, ինչին հետևում են Ջոյսը և Դևինդերը:
Այն պետք է հանել .txt ֆայլերը և դրանք բոլորը տեղադրել միմյանց տակ որոշակի սյունակում, ասենք «N» սյունակում:

Նաև պետք է իմանալ, թե արդյոք հնարավոր կլինի ավելացնել «եթե պայմանը», որպեսզի ներմուծված .txt ֆայլերը լինեն հետևյալը:
եթե .txt ֆայլերը սկսվում են «A» տառով, այնուհետև պետք է տեղադրվեն «թերթ 1»-ում՝ սկսած «N2» բջիջով:
և եթե .txt ֆայլերը սկսվում են «B» տառով, ապա տեղադրեք «Թերթ 2»-ում՝ սկսած «N2» բջիջով:
else MsgBox-ը պետք է լինի «Չճանաչված .txt ֆայլի նպատակը»:

նախորոք շնորհակալ եմ
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ես այս կոդը աշխատել եմ ինձ համար, բայց այնուամենայնիվ, ես պետք է որոշ չափով փոխեմ դրա մեջ:

*Ես ուզում եմ, որ այն տեղադրվի նույն թերթիկի վրա՝ առանց նոր թերթ բացելու, այնուհետև պատճենել, քանի որ ավելի երկար ժամանակ է պահանջվում:

*պետք է տեղադրել պայմանական, եթե ներմուծված txt ֆայլերը տեղադրվեն 1-ին թերթում, եթե այն սկսվում է A տառով և ներմուծվում է Թերթ 2, եթե այն սկսվում է B տառով:


Ենթաթեստային պատճեն 3()
Dim xWb որպես աշխատանքային գրքույկ
Dim xToBook As Workbook-ը
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Dim xFiles որպես նոր հավաքածու
Dim i քանի դեռ
Dim Last Row այնքան երկար
Dim Rng որպես միջակայք
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = "Ընտրեք թղթապանակ [Kutools for Excel]"
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Եթե ​​Right(xStrPath, 1) <> "\" Ապա xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & «*.txt»)
Եթե ​​xFile = "" Ապա
MsgBox «Ֆայլեր չեն գտնվել», vbInformation, «Kutools for Excel»
Ելք ենթ
Վերջ: Եթե
Do while xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Հանգույց
Շրջանակ ("N2"): Ընտրեք
Սահմանել xToBook = This Workbook
Եթե ​​xFiles.Count > 0 Ապա
i = 1-ի համար դեպի xFiles.Count
Սահմանել xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Ակտիվացնել
'Ընտրելով և պատճենելով txt տվյալները
Range(Selection, Selection.End(xlDown)).Ընտրեք
Ընտրություն.Պատճեն
xToBook.Ակտիվացնել
ActiveSheet.Paste
Ընտրություն.Վերջ(xlDown).Offset(1).Ընտրել
Ս.թ. սխալի Ռեզյումե Next
Սխալի դեպքում GoTo 0
xWb.Փակել կեղծ
հաջորդ
Վերջ: Եթե
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Կներեք, ձեռքերս կապված են
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Բարև, իմ կոդը աշխատում է, բայց ներմուծում է միայն առաջին ֆայլը: Այն ասում է, որ եղել է մեթոդի սխալ պատճենման համար: Վրիպազերծիչը կարևորում է կոդերի հետևյալ տողը. Կա՞ն գաղափարներ:


xWb.Worksheets(1).Պատճենել հետո՝=xToBook.Sheets(xToBook.Sheets.Count)
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ես նույն խնդիրն ունեմ, լուծումներ գտնվե՞լ են:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Հեյ Քեթի,
Ես գիտեմ, որ ձեր մեկնաբանությունը բավականին հին է, բայց ես բախվեցի նույն խնդրին և ուղղեցի այն այսպես. մոդուլը պետք է տեղադրվի ակտիվ .xlsx նախագծի ենթաթղթապանակում: Ես սխալ եմ թույլ տվել՝ պատճենել կոդը իմ PERSONAL.XLSB-ի ենթաթղթապանակում, որտեղ ես սովորաբար պահում եմ իմ մակրոները, և դա անում է իմ մյուս մակրոների հետ, բայց ոչ այս մեկի հետ:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ինչպե՞ս կջնջեիք թերթերը vba կոդի մեջ, եթե չեք ցանկանում կրկնօրինակներ մոդուլը վերագործարկելիս:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Կներեք, կոպիտ, պարզապես զգույշ եղեք՝ կրկնակի ներմուծումից խուսափելու համար:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Բարև, ես ուզում եմ կանխել excel-ում նախորդ զրոյի հեռացումը:

Ես փորձել եմ ստորև նշված կոդը, բայց այն չի աշխատում


Ենթաթեստ ()
Dim xWb որպես աշխատանքային գրքույկ
Dim xToBook As Workbook-ը
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Dim xFiles որպես նոր հավաքածու
Dim I As Long
Dim j As Long
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = «Ընտրեք թղթապանակ»
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Եթե ​​Right(xStrPath, 1) <> "\" Ապա xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & «*.txt»)
Եթե ​​xFile = "" Ապա
MsgBox «Ֆայլեր չեն գտնվել», vbInformation, «Kutools for Excel»
Ելք ենթ
Վերջ: Եթե
Do while xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Հանգույց
Սահմանել xToBook = This Workbook
Եթե ​​xFiles.Count > 0 Ապա
For I = 1 To xFiles.Count
Սահմանել xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Սա տեքստային ձևաչափով Excel դարձնելու համար նախքան տեքստային ֆայլի տվյալները կպցնելը
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
Ս.թ. սխալի Ռեզյումե Next
ActiveSheet.Name = xWb.Name
Սխալի դեպքում GoTo 0
xWb.Փակել կեղծ
հաջորդ
Վերջ: Եթե
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Pooja, դուք կարող եք փորձել Remove Leading Zeros գործառույթը Kutools- ի համար Excel- ի համար, ներմուծումից հետո ընտրության բոլոր առաջատար զրոները հեռացնելու համար:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
բայց ես չեմ ուզում հեռացնել: Ես ուզում եմ կանխել նախորդ զրոյի հեռացումը:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Եթե ​​ցանկանում եք պահպանել առաջատար զրոները, կարող եք դրանք ֆորմատավորել որպես տեքստային ձևաչափ՝ ըստ բջջային ձևաչափի:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, ինչպես կարող եք փոփոխել այս կոդը՝ *.txt ֆայլերը հերթականությամբ տեղադրելու համար՝ 1,2,3,4,5,6,7,8,9,10,11 և այլն: Ներկայումս կոդը տեղադրում է ֆայլերը հետևյալ կերպ. 1,10,11,12,13,14,15,16,17,18,19,2,20,21 և այլն: Շնորհակալություն:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
կա՞ հնարավորություն txt ֆայլերի անուններից միայն որոշակի մաս վերցնելու թերթերի անունները:

վերը նշված ծածկագրի համաձայն, թերթի ամբողջ անվանումն ընդունվել է:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
շատ շնորհակալություն Office 2007 excel-ում կատարած աշխատանքի համար
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Բարև, իմ կոդը աշխատում է, բայց ներմուծում է միայն առաջին ֆայլը: Այն ասում է, որ եղել է մեթոդի սխալ պատճենման համար: Վրիպազերծիչը կարևորում է կոդերի հետևյալ տողը. Կա՞ն գաղափարներ:


xWb.Worksheets(1).Պատճենել հետո՝=xToBook.Sheets(xToBook.Sheets.Count)
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Հեյ Մարտինյո,
Ես ունեի նույն խնդիրը և լուծեցի այն՝ փոխելով այս տողը.
Սահմանել xToBook = This Workbook
դեպի
Սահմանել xToBook = ActiveWorkbook
Գուցե սա օգնում է:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
0

Ես ձեր օգնության կարիքն ունեմ, ես գաղափար չունեմ vba excel-ում, ես ուզում եմ ներմուծել մի քանի տեքստային ֆայլ, ինչպիսին 13000-ն է: տեքստային ֆայլի անունը նույնն է, ինչ բջիջը, օրինակ (c1=112, ուստի տեքստային ֆայլի անունը նույնպես 112 է) նշանակում է, որ տեքստային ֆայլը 112 է: ներմուծել c112-ը:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ես ձեր օգնության կարիքն ունեմ, ես գաղափար չունեմ vba excel-ում, ես ուզում եմ ներմուծել մի քանի տեքստային ֆայլ, ինչպիսին 13000-ն է: տեքստային ֆայլի անունը նույնն է, ինչ բջիջը, օրինակ (c1=112, ուստի տեքստային ֆայլի անունը նույնպես 112 է) նշանակում է, որ տեքստային ֆայլը 112 է: ներմուծել c112-ը:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Կոդն աշխատում է, բայց յուրաքանչյուր տեքստային ֆայլ ներմուծում է աշխատանքային գրքի նոր ներդիր: Պատկերացնո՞ւմ եք, թե կոդի մեջ որտեղ կարելի է փոխել այն՝ ներմուծելու նոր տեքստային ֆայլը նույն աշխատաթերթի վրա՝ վերջին տեքստային ֆայլի տվյալների տակ:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ստորև բերված կոդում, եթե ես ուզում եմ նշել թղթապանակը, այլ ոչ թե ամեն անգամ տեքստային ֆայլ ներմուծելիս ընտրել ուղին, ինչ փոփոխություն պետք է անեմ

VBA ԿՈԴ:

Sub ImportCSVsWithReference()
«Թարմացում ըստ կուտոուլսների Excel20151214-ի համար
Dim xSht As Worksheet
Dim xWb որպես աշխատանքային գրքույկ
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Սխալի դեպքում GoTo ErrHandler
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = "Ընտրեք թղթապանակ [Kutools for Excel]"
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Սահմանել xSht = ThisWorkbook.ActiveSheet
Եթե ​​MsgBox («Մաքրել առկա թերթիկը ներմուծումից առաջ», vbYesNo, «Kutools for Excel») = vbYes Այնուհետեւ xSht.UsedRange.Clear
Դիմում. ScreenUpdating = Սուտ է
xFile = Dir(xStrPath & "\" & "*.txt")
Do while xFile <> ""
Սահմանել xWb = Workbooks.Open (xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Փակել կեղծ
xFile = Ռեժ
Հանգույց
Դիմում. ScreenUpdating = ueիշտ է
Ելք ենթ
ErrHandler:
MsgBox «txt ֆայլեր չկան», , «Excel-ի համար նախատեսված գործիքներ»
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, փորձեք ստորև նշված կոդը
Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    xStrPath = "C:\Users\AddinsVM001\Desktop\test" 'Here is the parth you can modify
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

«C:\Users\AddinsVM001\Desktop\test»-ը թղթապանակի ուղին է, որտեղից կարող եք ներմուծել տեքստային ֆայլ, խնդրում ենք փոխել այն ըստ անհրաժեշտության:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, շնորհակալություն ձեր արժեքավոր VBA կոդի համար:
Այնուամենայնիվ, ինձ անհրաժեշտ է կոդ մի քանի txt ֆայլերի համար՝ «աշխատանքային թերթում մեկ թերթիկ, այլ ոչ թե յուրաքանչյուր txt ֆայլի առանձին թերթ»:
Ի՞նչ պետք է խմբագրեմ ձեր կոդը իմ նպատակի համար:

Thanks,
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, փորձեք ստորև նշված կոդը
Sub Test()
    'UpdatebyExtendoffice 10/26/2022
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xSaveRg As Range
    Dim xSh As Worksheet
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    Set xSh = xToBook.Sheets.Add
    Set xRg = xSh.Range("A1")
    J = 1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            Set xSaveRg = xWb.Worksheets(1).UsedRange
            J = xSaveRg.Rows.Count + 1 + J
            Debug.Print xRg.Address
            xSaveRg.Copy Destination:=xRg
            On Error Resume Next
            xWb.Close False
            
            Set xRg = xSh.Cells(J, 1)
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Սա լավ է աշխատում: Բայց երբ ներմուծում է, այն վերանվանում է name.txt թերթիկները, ինչպե՞ս անել, որ այն պահպանի միայն անունը՝ առանց թերթին .txt ընդլայնում ավելացնելու:
Գնահատված 3.5- ը 5- ից դուրս է
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ok nvm-ն գտել է պատասխանը Google-ի օգնությամբ:
փոխարինել տողը.
ActiveSheet.Name = xWb.Name
հետ:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
թերթի անունից կհեռացներ վերջին 4 տառերը: Արդյունավետորեն ինձ տալով այն, ինչ ինձ անհրաժեշտ էր: անունը առանց .txt
Կենացը
Գնահատված 4- ը 5- ից դուրս է
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
ստորև բերված կոդը կարող է տվյալները բաժանել սյունակների՝ հիմնվելով տարածության կամ ներդիրի վրա՝ տեքստային ֆայլը թերթիկներ ներմուծելիս: Բայց ես չեմ ուզում առանձին ներդիր յուրաքանչյուր txt ֆայլի համար, ես կցանկանայի, որ դրանք բոլորը մեկ թերթիկի տակ լինեն: Յուրաքանչյուր ֆայլի համար տեղեկատվությունը նույն ձևաչափն է: . Ինչը կարող է փոփոխվել, որպեսզի սա լինի մեկ թերթիկ, փոխարենը ներմուծված յուրաքանչյուր ֆայլ լինի նոր ներդիր, ցանկացած օգնություն կգնահատվի:

Sub ImportTextToExcel()
― ԹարմացնելովExtendoffice20180911
Dim xWb որպես աշխատանքային գրքույկ
Dim xToBook As Workbook-ը
Dim xStrPath որպես տող
Խոնավեցրեք xFileDialog-ը որպես FileDialog
Խոնավեցրեք xFile-ը որպես տող
Dim xFiles որպես նոր հավաքածու
Dim I As Long
Dim xIntRow այնքան երկար
Dim xFNum, xFArr այնքան երկար
Dim xStrValue որպես տող
Dim xRg որպես տիրույթ
Dim xArr
Սահմանել xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Սխալ
xFileDialog.Title = "Ընտրեք թղթապանակ [Kutools for Excel]"
Եթե ​​xFileDialog.Show = -1 Ապա
xStrPath = xFileDialog.SelectedItems(1)
Վերջ: Եթե
Եթե ​​xStrPath = "" Ապա դուրս եկեք Sub
Եթե ​​Right(xStrPath, 1) <> "\" Ապա xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & «*.txt»)
Եթե ​​xFile = "" Ապա
MsgBox «Ֆայլեր չեն գտնվել», vbInformation, «Kutools for Excel»
Ելք ենթ
Վերջ: Եթե
Do while xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Հանգույց
Սահմանել xToBook = This Workbook
Ս.թ. սխալի Ռեզյումե Next
Դիմում. ScreenUpdating = Սուտ է
Եթե ​​xFiles.Count > 0 Ապա

For I = 1 To xFiles.Count
Սահմանել xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Պատճենել հետո՝=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Փակել կեղծ
xIntRow = ActiveCell.CurrentRegion.Rows.Count
xFNum = 1-ից դեպի xIntRow
Սահմանել xRg = ActiveSheet.Range («A» և xFNum)
xArr = Split (xRg.Text, " ")
Եթե ​​UBound(xArr) > 0 Ապա
xFArr-ի համար = 0 Դեպի UBound (xArr)
Եթե ​​xArr(xFArr) <> "" Ապա
xRg.Value = xArr(xFArr)
Սահմանել xRg = xRg.Offset(ColumnOffset:=1)
Վերջ: Եթե
հաջորդ
Վերջ: Եթե
հաջորդ
հաջորդ
Վերջ: Եթե
Դիմում. ScreenUpdating = ueիշտ է
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, Դանիել, փորձիր ներքևի կոդը, այն ներմուծում է բոլոր տեքստային ֆայլերը մեկ թերթում՝ Txt:
Ուշադրություն դարձրեք, որ եթե տեքստի անունը նույնն է առկա թերթի անվան հետ, տեքստային ֆայլը կարող է չներմուծվել:
Sub ImportTextToExcel2()

'UpdatebyExtendoffice20230106

Dim xWb As Workbook

Dim xToBook As Workbook

Dim xStrPath As String

Dim xFileDialog As FileDialog

Dim xFile As String

Dim xFiles As New Collection

Dim I As Long

Dim xIntRow As Long

Dim xFNum, xFArr As Long

Dim xStrValue As String

Dim xRg As Range

Dim xArr

Dim xRowL, xRowH As Integer

Dim xTxtWS, xWSD As Worksheet

Dim xTxtWS_Rg As Range

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

xFileDialog.AllowMultiSelect = False

xFileDialog.Title = "Select a folder [Kutools for Excel]"

If xFileDialog.Show = -1 Then

xStrPath = xFileDialog.SelectedItems(1)

End If

If xStrPath = "" Then Exit Sub

If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"

xFile = Dir(xStrPath & "*.txt")

If xFile = "" Then

MsgBox "No files found", vbInformation, "Kutools for Excel"

Exit Sub

End If

Do While xFile <> ""

xFiles.Add xFile, xFile

xFile = Dir()

Loop

Set xToBook = ThisWorkbook

On Error Resume Next

Set xTxtWS = xToBook.Worksheets("Txt")

If IsNull(xTxtWS) Or IsEmpty(xTxtWS) Then

    Set xTxtWS = xToBook.Worksheets.Add

    xTxtWS.Name = "Txt"

End If

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xTxtWS.Activate

If xFiles.Count > 0 Then

xRowL = 1

For I = 1 To xFiles.Count

Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))

xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

Set xWSD = xToBook.Sheets(xToBook.Sheets.Count)

xTxtWS.Activate

xWb.Close False

xIntRow = xWSD.UsedRange.CurrentRegion.Rows.Count

    For xFNum = 1 To xIntRow

        Set xRg = xWSD.Range("A" & xFNum)

        xArr = Split(xRg.Text, " ")

        Set xTxtWS_Rg = xTxtWS.Cells.Range("A" & xRowL)

'        If UBound(xArr) > 0 Then

            For xFArr = 0 To UBound(xArr)

                If xArr(xFArr) <> "" Then

                xTxtWS_Rg.Value = xArr(xFArr)

                Set xTxtWS_Rg = xTxtWS_Rg.Offset(ColumnOffset:=1)

                End If

            Next

'        End If

xRowL = xRowL + 1

    Next

xWSD.Delete

Next

End If

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub


Առայժմ ոչ մի մեկնաբանություն չկա

Հետեւեք մեզ

Հեղինակային իրավունքի © 2009 - www.extendoffice.com. | Բոլոր իրավունքները պաշտպանված են. Powered by ExtendOffice. | | Կայքի քարտեզ
Microsoft- ը և Office- ի պատկերանշանը հանդիսանում են Microsoft Corporation- ի ապրանքային նշաններ կամ գրանցված ապրանքային նշաններ ԱՄՆ-ում և (կամ) այլ երկրներում:
Պաշտպանված է Sectigo SSL- ի կողմից