Cần mọi người hỗ trợ giúp code xuất dữ liệu từ 1 vùng sang file TXT (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
minhtuan55

minhtuan55

Thành viên bị đình chỉ hoạt động
Thành viên bị đình chỉ hoạt động
Tham gia
23/3/16
Bài viết
705
Được thích
52
Em xin chào cả nhà GPE. Hôm nay là bài đầu tiên sau lệnh khóa gần 2 tháng.
Ví dụ em có 1 vùng B3:B100 em muốn xuất sang 1 file Notepad có tên "Data.txt" nằm cùng thư mục với File excel thì em viết code ra làm sao. rất mong mọi người hổ trợ. Mình xin chân thành cảm ơn ạ

Và lưu ý: Do có 1 vài thành viên trong diễn đàn vẫn còn sân si với mình. mặc dù mình đã làm 1 topic xin lổi sáng nay. Nên từ sau về sau mình không mong muốn chuyện đó xảy ra nữa. Cụ thể các bài của mình đăng mình sẻ không cần các thành viên có tên sau trả lời

PacificPR
thuyyeu99
VetMini
befaint

Vì thường xuyên trả lời không đúng chủ đề của người hỏi. Thường xuyên châm chọc gây ra mâu thuẩn mất đoàn kết. Nếu ai biết thì trả lời mình vô cùng cảm ơn. còn 4 thành viên phía trên thì cho dù trả lời mình cũng không thèm đọc nữa. Em xin hết

1585993627070.png
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
minhtuan55 đã viết:
Em xin chào cả nhà GPE. Hôm nay là bài đầu tiên sau lệnh khóa gần 2 tháng.
Ví dụ em có 1 vùng B3:B100 em muốn xuất sang 1 file Notepad có tên "Data.txt" nằm cùng thư mục với File excel thì em viết code ra làm sao. rất mong mọi người hổ trợ. Mình xin chân thành cảm ơn ạ

Và lưu ý: Do có 1 vài thành viên trong diễn đàn vẫn còn sân si với mình. mặc dù mình đã làm 1 topic xin lổi sáng nay. Nên từ sau về sau mình không mong muốn chuyện đó xảy ra nữa. Cụ thể các bài của mình đăng mình sẻ không cần các thành viên có tên sau trả lời

PacificPR
thuyyeu99
VetMini
befaint

Vì thường xuyên trả lời không đúng chủ đề của người hỏi. Thường xuyên châm chọc gây ra mâu thuẩn mất đoàn kết. Nếu ai biết thì trả lời mình vô cùng cảm ơn. còn 4 thành viên phía trên thì cho dù trả lời mình cũng không thèm đọc nữa. Em xin hết

View attachment 234739
Nhấp chuột vào đây để mở rộng...
Từng nhìn thấy cách làm bài này rồi. Lười tìm lại
 
Upvote 0
Upvote 0
Nếu bạn biết VBA, thì có thể vận dụng đoạn code dưới đây.


File sẽ được lưu không chứa UTF-8 BOM.
-----------------------------
JavaScript: 
Sub SaveAsTxtFile()
  Dim i As Long, j As Long, Arr, Text As String, fileName As String
  Arr = Range("B2").CurrentRegion.Value
  j = UBound(Arr, 1)
  If j > 1 Then
    If UBound(Arr, 2) > 1 Then
      For i = 1 To j
        Text = VBA.IIf(Text = "", "", Text & VBA.vbNewLine) & VBA.Join(Application.Index(Arr, i, 0), VBA.vbTab)
      Next i
    Else
      Text = VBA.Join(Application.Transpose(Arr), VBA.vbNewLine)
    End If
    Call CreateFile("text.txt", ThisWorkbook.Path, Text)
    'Call CreateFile("text.txt", "<Folder Name>", Text)
  End If
End Sub
Sub CreateFile(ByVal fileName As String, _
               ByVal FolderPath As String, _
      Optional ByVal Text As String = "", _
      Optional ByVal OverWriteFiles As Boolean = True, _
      Optional ByVal ReplaceSpaceName As String = " ")
  fileName = VBA.Strings.Replace(fileName, " ", ReplaceSpaceName)
  Dim UTFStream As Object, BinaryStream As Object
  Dim FullName$, FSO As Object
  Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
  FullName = FolderPath & VBA.IIf(RIGHT(FolderPath, 1) Like "[\/]", "", "\") & fileName
  If Not OverWriteFiles Then
    If FSO.FileExists(FullName) Then GoTo Ends
  Else
    If FSO.FileExists(FullName) Then FSO.DeleteFile FullName, True
  End If
  GoSub MakeFolder
  Dim FolderArray, Tmp$, Item, tFolder$
  On Error GoTo Ends
  Set UTFStream = VBA.CreateObject("ADODB.Stream")
  Set BinaryStream = VBA.CreateObject("ADODB.Stream")
  UTFStream.Type = 2 'adTypeText
  UTFStream.Mode = 3 'adModeReadWrite
  UTFStream.Charset = "UTF-8"
  UTFStream.Open
  UTFStream.WriteText Text
  UTFStream.Position = 3 'skip BOM
  BinaryStream.Type = 1 'adTypeBinary
  BinaryStream.Mode = 3 'adModeReadWrite
  BinaryStream.Open
  UTFStream.CopyTo BinaryStream
  BinaryStream.SaveToFile FullName, 2 'adSaveCreateOverWrite
  BinaryStream.flush
  UTFStream.Close
  BinaryStream.Close
Ends:
On Error Resume Next
  UTFStream.Close: BinaryStream.Close
  Set UTFStream = Nothing: Set BinaryStream = Nothing: Set FSO = Nothing
On Error GoTo 0
Exit Sub
MakeFolder:
  On Error Resume Next
  tFolder = FolderPath
  If RIGHT(tFolder, 1) = "\" Then tFolder = LEFT(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = VBA.Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = VBA.Split(tFolder, "\")
  FolderArray(0) = VBA.Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  With FSO
    For Each Item In FolderArray
      Tmp = Tmp & Item & "\"
      If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
    Next
  End With
  On Error GoTo 0
Return
End Sub
 
Upvote 0
minhtuan55 đã viết:
Em xin chào cả nhà GPE. Hôm nay là bài đầu tiên sau lệnh khóa gần 2 tháng.
Ví dụ em có 1 vùng B3:B100 em muốn xuất sang 1 file Notepad có tên "Data.txt" nằm cùng thư mục với File excel thì em viết code ra làm sao. rất mong mọi người hổ trợ. Mình xin chân thành cảm ơn ạ

Và lưu ý: Do có 1 vài thành viên trong diễn đàn vẫn còn sân si với mình. mặc dù mình đã làm 1 topic xin lổi sáng nay. Nên từ sau về sau mình không mong muốn chuyện đó xảy ra nữa. Cụ thể các bài của mình đăng mình sẻ không cần các thành viên có tên sau trả lời

PacificPR
thuyyeu99
VetMini
befaint

Vì thường xuyên trả lời không đúng chủ đề của người hỏi. Thường xuyên châm chọc gây ra mâu thuẩn mất đoàn kết. Nếu ai biết thì trả lời mình vô cùng cảm ơn. còn 4 thành viên phía trên thì cho dù trả lời mình cũng không thèm đọc nữa. Em xin hết

View attachment 234739
Nhấp chuột vào đây để mở rộng...

Bạn thử xem được không?
Mã: 
Option Explicit

Sub Kommentar_Tab()
    'https://stackoverflow.com/questions/16395154/copy-used-range-to-text-file/16396129#16396129
    Dim wbSource As Workbook, wsSource As Worksheet, wbDest As Workbook, fName As String
    
    Set wbSource = ActiveWorkbook
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wbDest = Workbooks.Add

    wsSource.Range("B2").CurrentRegion.Copy
    wbDest.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    fName = ThisWorkbook.Path & "\Data.txt"

    wbDest.SaveAs fName, FileFormat:=xlUnicodeText
    wbDest.Close SaveChanges:=True

End Sub
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Bạn thử xem được không?
Mã: 
Option Explicit

Sub Kommentar_Tab()
    'https://stackoverflow.com/questions/16395154/copy-used-range-to-text-file/16396129#16396129
    Dim wbSource As Workbook, wsSource As Worksheet, wbDest As Workbook, fName As String
   
    Set wbSource = ActiveWorkbook
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wbDest = Workbooks.Add

    wsSource.Range("B2").CurrentRegion.Copy
    wbDest.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    fName = ThisWorkbook.Path & "\Data.txt"

    wbDest.SaveAs fName, FileFormat:=xlUnicodeText
    wbDest.Close SaveChanges:=True

End Sub
Nhấp chuột vào đây để mở rộng...
Tuyệt vời đúng ý mình luôn. cảm ơn bạn rất nhiều. Chúc bạn và gia đình bạn 1 ngày cuối tuần vui vẽ hạnh phúc
Bài đã được tự động gộp:

HeSanbi đã viết:
Nếu bạn biết VBA, thì có thể vận dụng đoạn code dưới đây.


File sẽ được lưu không chứa UTF-8 BOM.
-----------------------------
JavaScript: 
Sub SaveAsTxtFile()
  Dim i As Long, j As Long, Arr, Text As String, fileName As String
  Arr = Range("B2").CurrentRegion.Value
  j = UBound(Arr, 1)
  If j > 1 Then
    If UBound(Arr, 2) > 1 Then
      For i = 1 To j
        Text = VBA.IIf(Text = "", "", Text & VBA.vbNewLine) & VBA.Join(Application.Index(Arr, i, 0), VBA.vbTab)
      Next i
    Else
      Text = VBA.Join(Application.Transpose(Arr), VBA.vbNewLine)
    End If
    Call CreateFile("text.txt", ThisWorkbook.Path, Text)
    'Call CreateFile("text.txt", "<Folder Name>", Text)
  End If
End Sub
Sub CreateFile(ByVal fileName As String, _
               ByVal FolderPath As String, _
      Optional ByVal Text As String = "", _
      Optional ByVal OverWriteFiles As Boolean = True, _
      Optional ByVal ReplaceSpaceName As String = " ")
  fileName = VBA.Strings.Replace(fileName, " ", ReplaceSpaceName)
  Dim UTFStream As Object, BinaryStream As Object
  Dim FullName$, FSO As Object
  Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
  FullName = FolderPath & VBA.IIf(RIGHT(FolderPath, 1) Like "[\/]", "", "\") & fileName
  If Not OverWriteFiles Then
    If FSO.FileExists(FullName) Then GoTo Ends
  Else
    If FSO.FileExists(FullName) Then FSO.DeleteFile FullName, True
  End If
  GoSub MakeFolder
  Dim FolderArray, Tmp$, Item, tFolder$
  On Error GoTo Ends
  Set UTFStream = VBA.CreateObject("ADODB.Stream")
  Set BinaryStream = VBA.CreateObject("ADODB.Stream")
  UTFStream.Type = 2 'adTypeText
  UTFStream.Mode = 3 'adModeReadWrite
  UTFStream.Charset = "UTF-8"
  UTFStream.Open
  UTFStream.WriteText Text
  UTFStream.Position = 3 'skip BOM
  BinaryStream.Type = 1 'adTypeBinary
  BinaryStream.Mode = 3 'adModeReadWrite
  BinaryStream.Open
  UTFStream.CopyTo BinaryStream
  BinaryStream.SaveToFile FullName, 2 'adSaveCreateOverWrite
  BinaryStream.flush
  UTFStream.Close
  BinaryStream.Close
Ends:
On Error Resume Next
  UTFStream.Close: BinaryStream.Close
  Set UTFStream = Nothing: Set BinaryStream = Nothing: Set FSO = Nothing
On Error GoTo 0
Exit Sub
MakeFolder:
  On Error Resume Next
  tFolder = FolderPath
  If RIGHT(tFolder, 1) = "\" Then tFolder = LEFT(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = VBA.Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = VBA.Split(tFolder, "\")
  FolderArray(0) = VBA.Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  With FSO
    For Each Item In FolderArray
      Tmp = Tmp & Item & "\"
      If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
    Next
  End With
  On Error GoTo 0
Return
End Sub
Nhấp chuột vào đây để mở rộng...
Quá pro. Tuyệt vời đúng ý mình luôn. cảm ơn bạn rất nhiều. Chúc bạn và gia đình bạn 1 ngày cuối tuần vui vẽ hạnh phúc
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

A
  • Question Question
Viết code tạo mã hàng hóa (4 người xem)
Trả lời
3
Đọc
41
SA_DQ
SA_DQ
K
Không đăng nhập được MS Teams sau khi tải về (chỉ cho sử dụng bản trên web) (3 người xem)
Trả lời
3
Đọc
34
K&B
K
D
Nhờ mọi người giúp với. file đính kèm ạh (2 người xem)
    • Cười
Trả lời
6
Đọc
98
SA_DQ
SA_DQ
A
  • Question Question
Nhờ các bác giúp em viết code để trích lọc và so sánh với 5 điều kiện. Em suy nghĩ mãi không làm được. em cám ơn (5 người xem)
Trả lời
5
Đọc
132
A HOANG 620
A
H
Phân quyền xem trên từng trang tính của googlesheet (1 người xem)
Trả lời
5
Đọc
86
Hoale85
H
H
Hàm Evaluate bị lỗi khi mở lại (1 người xem)
Trả lời
12
Đọc
146
ptm0412
ptm0412
T
Nhờ ACE chỉ giáo công thức Gộp nhiều dữ liệu vào một ô trong excel
Trả lời
6
Đọc
144
thuong-minh
T
E
Tính tổng tiền theo điều kiện
Trả lời
5
Đọc
141
mimosa1972
M
vnxgiokinhtoi
Nhờ giúp đỡ công thức lưu dữ liệu và mở lại dữ liệu cũ đã save (1 người xem)
Trả lời
0
Đọc
43
vnxgiokinhtoi
vnxgiokinhtoi
N
  • Question Question
TÌM TÊN CỘT VÀ COPY CẢ CỘT SANG SHEET KHÁC BẰNG VBA
Trả lời
5
Đọc
142
ngoc0977760224
N
N
  • Question Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
7
Đọc
429
nguyenhuong91
N
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau
Trả lời
2
Đọc
170
Cúc Hr
C
M
  • Question Question
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
5
Đọc
227
Cúc Hr
C
PhanTuHuong
Nên chọn điện thoại nào?
Trả lời
17
Đọc
1K
minhminh27
minhminh27
N
Em đang muốn tìm sách. Tài.liệu về dashboard và báo cáo, biểu đồ excel tiếng việt (1 người xem)
Trả lời
1
Đọc
77
ptm0412
ptm0412
Q
Phát tiếng khi code chạy ra giá trị yêu cầu (1 người xem)
    • Cười
Trả lời
3
Đọc
159
DeTong
D
A
  • Question Question
nhờ anh chị, chú bác giúp em gom gọn phần code phía dưới giúp em. Sao bị lỗi ở dòng 24, 25, 26 nữa ạ. em cám ơn
Trả lời
3
Đọc
103
Hoàng Tuấn 868
H
J
Excel 2019, lỗi không thể insert được biểu đồ (chart)
Trả lời
12
Đọc
4K
ptm0412
ptm0412
C
Lọc chỉ tiêu sheet 1, kết quả tự động ở các sheet còn lại
Trả lời
10
Đọc
204
thuytrangbp28
T
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
13
Đọc
389
HUONGHCKT
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom