Excel VBA - 文本文件和文件夹操作实例集锦(4)

ElseIf temp <> Chr(34) Then str = str & temp End If Next i y = 0 x = x + 1 Loop Close #1

Application.ScreenUpdating = True End Sub

Sub fuz0619() '复制

' 蓝桥玄霜 2007-6-20 '

Dim Myr%, x%, n%, r1, Myc%, aa, res Dim Sht1 As Worksheet Dim Sht2 As Worksheet

Application.ScreenUpdating = False Set Sht1 = Sheets(1) Set Sht2 = Sheets(2) n = 2

Sht1.Activate

Myr = [a65536].End(xlUp).Row Sht2.Activate [b1] = 1: [c1] = 2

Range(\Sht1.Activate Call Uniquedata

For y = 0 To bb

For x = 3 To Myr + 1

If Sht1.Cells(x, 1) <> \

If Sht1.Cells(x, 1) = Sht1.Cells(y + 3, 8) Then

If Sht1.Cells(x, 1) <> Sht1.Cells(x - 1, 1) Then Sht2.Cells(n, 1) = Cells(x, 1) End If

aa = Cells(x, 2)

Set r1 = Sht2.Range(\ If Not r1 Is Nothing Then Myc = r1.Column

Sht2.Cells(n, Myc) = Cells(x, 3) End If Else

GoTo 100 End If End If 100:

Next x n = n + 1 Next y

Sht2.Activate

Myr = [a65536].End(xlUp).Row Range(\

Selection.NumberFormatLocal = \ Selection.FormatConditions.Delete

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:=\

Selection.FormatConditions(1).Interior.ColorIndex = 3 Application.ScreenUpdating = True End Sub

Sub Uniquedata() '不重复值

'引用自实战精粹

Dim Cel As Range, d, i%

Set d = CreateObject(\ Set Sht1 = Sheets(1) n = 3

Sht1.Activate

Myr = [a65536].End(xlUp).Row

For Each Cel In Sht1.Range(\ If Cel <> \

If Not d.exists(Cel.Value) Then d.Add Cel.Value, Cel.Value End If End If Next

res = d.Items

bb = UBound(res) For x = 0 To bb

Cells(n, 8) = res(x) n = n + 1 Next x End Sub

Sub qukh()

'去除表1空白行

'2007/6/20

Application.ScreenUpdating = False Set Sht1 = Sheets(1)

Myr = [a65536].End(xlUp).Row For x = 3 To Myr

If Left(Cells(x, 1), 1) <> \

Cells(x, 1).EntireRow.Delete shift:=xlUp Myr = Myr - 1: x = x - 1 If x > Myr Then Exit Sub End If Next x

Application.ScreenUpdating = True End Sub

11，按日期段和条件导出数据，另存为文件

‘http://www.excelpx.com/dispbbs.asp?boardID=5&ID=27397&page=1 ‘5550925.xls （自编宏之三） Option Explicit Dim x%, n1%

Dim Sht1 As Worksheet, Sht As Worksheet Sub daocu()

Dim ksrq As Date, jsrq As Date Dim ksnm$, jsnm$, n, nn, nm Dim Myr%, arr1, y%, i% Dim sFilenm$

Application.ScreenUpdating = False

If UserForm1.TextBox1.Value = \alue = \Set Sht1 = Sheets(\Sht1.Activate

Range(Cells(2, 1), Cells(2000, 26)).ClearContents ksrq = UserForm1.TextBox1.Value jsrq = UserForm1.TextBox2.Value n = DateDiff(\

ksnm = Right(Year(ksrq), 2) & Application.WorksheetFunction.Text(Month(ksrq), \jsnm = Right(Year(jsrq), 2) & Application.WorksheetFunction.Text(Month(jsrq), \ReDim nn(1 To n) ReDim nm(1 To n) For i = 1 To n If i = 1 Then

nm(1) = ksnm: nn(1) = CInt(ksnm) Else

nn(i) = nn(i - 1) + 1

If Right(nn(i), 2) = \

nm(i) = Application.WorksheetFunction.Text(nn(i), \ End If Next i n1 = 2

For i = 1 To UBound(nn) For Each Sht In Sheets

If Sht.Name = nm(i) Then Sht.Activate

Myr = [a65536].End(xlUp).Row For x = 2 To Myr

If Cells(x, 2) >= ksrq And Cells(x, 2) <= jsrq Then Call daocu1 n1 = n1 + 1 End If Next x End If Next Sht Next i

Sht1.Activate

Application.ScreenUpdating = True Sht1.Copy

sFilenm = Application.GetSaveAsFilename(filefilter:=\ActiveWorkbook.SaveAs sFilenm, xlText MsgBox \数据已导出! \End Sub

Sub daocu1() '选择导出 Dim xx%

For xx = 0 To 25

If UserForm1.ListBox1.Selected(xx) = True Then Cells(x, xx + 1).Copy Sht1.Cells(n1, xx + 1) End If Next xx End Sub

12，导出到多文本文件

Sub dcdwb()

'导出到文本文件 （自编宏之二） ‘请赐教0608.xls

‘http://club.excelhome.net/dispbbs.asp?boardID=2&ID=245438&page=1&px=0 '2007/6/8

Dim Filename$, Data$, aa$,Mypa$ Dim rows As Long, cols%

Dim i%, j%, Myr%, rr%, add%, n% Dim cell As Range

Application.ScreenUpdating = False Mypa = ThisWorkbook.Path & \Myr = [b65536].End(xlUp).Row: n = 2 Range(\

If [a1] = \★\Do Until ActiveCell.Row > Myr

Cells.Find(What:=\★\ rr = ActiveCell.Row

ActiveCell.Offset(-rr + n, 1).Resize(rr - n, 1).Select Set cell = Selection '选择数据 cols = cell.Columns.Count rows = cell.rows.Count

Filename = Mypa & aa & \ ‘文件名 Open Filename For Output As #1 For i = 1 To rows

Data = cell.Cells(i, cols) '一列数据

If IsEmpty(cell.Cells(i, cols)) Then Data = \ Print #1, (Data) '字符串型可去除\ Next i Close #1

ActiveCell.Offset(rr - n, -1).Resize(1, 1).Select aa = Cells(rr, 2).Text ‘文件名 n = rr + 1 Loop

Application.ScreenUpdating = True End Sub

Sub dcdwb2()

'导出到一个文本文件 '水平数据 '2007/6/8

Dim Filename$, Data$, aa$, Mypa$ Dim rows As Long, cols%, cols1% Dim i%, j%, Myr%, rr%, add%, n%