提取A列然后粘贴？

zachery

测试.zip (9.3 KB, 下载次数: 3)

2019-2-16 19:24 上传

点击文件名下载附件

       自己尝试写了下 循环中老是卡死  只能成功粘贴最后一条，请老师们棒棒忙，谢谢！！

唐朝123

Sub ???1_Click()
    Dim Arr, Ary, k%
    Arr = ActiveSheet.UsedRange
    ReDim Ary(1 To UBound(Arr))
    For k = 1 To UBound(Arr)
        Ary(k) = Trim(Join(Application.Index(Arr, k)))
    Next
    Open ThisWorkbook.Path & "\合并.txt" For Output As #1
    Print #1, Join(Ary, vbCrLf): Reset
End Sub

ww87725244

1. Sub aa()
   
2. Dim d As Object, ar, i&, ph$, d1 As Object, a%, b%
   
3. Set d = CreateObject("scripting.filesystemobject")
   
4. a = MsgBox("请选择需要存放数据的文本文档", vbOKCancel)
   
5. If a = 1 Then
   
6.     With Application.FileDialog(msoFileDialogFilePicker)
   
7.         If .Show = -1 Then
   
8.             ph = .SelectedItems(1)
   
9.         Else
   
10.             Exit Sub
    
11.         End If
    
12.     End With
    
13.     b = MsgBox("是否清除原有数据？", vbOKCancel)
    
14.     If b = 1 Then
    
15.         Set d1 = d.opentextfile(ph, 2, True)
    
16.     Else
    
17.         Set d1 = d.opentextfile(ph, 8, True)
    
18.     End If
    
19.     With Sheet1
    
20.         ar = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(3))
    
21.         For i = 1 To UBound(ar)
    
22.             d1.writeline ar(i, 1)
    
23.         Next
    
24.         d1.Close
    
25.     End With
    
26. Else
    
27.     Exit Sub
    
28. End If
    
29. Set d = Nothing
    
30. Set d1 = Nothing
    
31. End Sub

复制代码