TXT批量单独VBA制盘参考（2）

EthanHunt

Private Sub CommandButton4_Click() '批量一次OK—————4

Dim wb As Workbook

Dim ws As Worksheet

Dim lngRow          As Long

Dim lngCol          As Long

Dim strContent      As String

Dim EndRow As Single

Dim i&, j&, k&, m$, l$

Dim fn, fp

fp = ThisWorkbook.Path & "\1待处理文件\"

fn = Dir(fp & "*.xl*")

Application.DisplayAlerts = False

Application.ScreenUpdating = True

On Error Resume Next

Do While fn <> ""

Set wb = Workbooks.Open(fp & fn)

For Each ws In wb.Worksheets

With ws

On Error Resume Next

ActiveWorkbook.Sheets(1).Range("A:D").Copy

ThisWorkbook.Sheets(17).Range("A:D").PasteSpecial Paste:=xlPasteValues

For i = 250 To 1 Step -1

   If ThisWorkbook.Sheets(17).Cells(i, 4).Text Like "0" Or ThisWorkbook.Sheets(17).Cells(i, 4).Text Like "" Then

  Cells(i, 4).EntireRow.Delete

   End If

Next

For i = 250 To 1 Step -1

      If ThisWorkbook.Sheets(17).Cells(i, 3).Text Like "62*" Or ThisWorkbook.Sheets(17).Cells(i, 3).Text Like "8001000*" Then

      Else

       Cells(i, 3).EntireRow.Delete

       End If

   Next

ThisWorkbook.Sheets(17).Columns("D:D").NumberFormatLocal = "G/通用格式"

ThisWorkbook.Sheets(17).Columns("A:D").Select

Selection.Replace What:=" ", Replacement:=""

j = Application.WorksheetFunction.Count(ThisWorkbook.Sheets(17).[D:D])

For k = 1 To j

Cells(k, 1) = k

Next k

ActiveWorkbook.Sheets(1).Range("A1").Copy

ThisWorkbook.Sheets(17).Range("I1").PasteSpecial Paste:=xlPasteValues

Selection.Paste

ThisWorkbook.Sheets(17).Range("I1").Select

ThisWorkbook.Sheets(17).Range("I1").Replace What:=" ", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="普宁市大坝镇", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="大坝镇", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="教师", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="初级中学", Replacement:="中学"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="学校小学", Replacement:="小学"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="小学学校", Replacement:="小学"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="学校", Replacement:="小学"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="月个*", Replacement:="月个人所得税"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="个人*", Replacement:="个人所得税"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="个税*", Replacement:="个人所得税"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="职业*", Replacement:="职业年金"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="月社保职业*", Replacement:="职业年金"

l = ThisWorkbook.Sheets(17).Shapes.Range(Array("TextBox 1")).TextFrame.Characters.Caption

Open ThisWorkbook.Path & "\2TXT\" & ThisWorkbook.Sheets(17).Range("I1").Text & ".txt" For Output As #1

m = Application.WorksheetFunction.Count(ThisWorkbook.Sheets(17).[A:A])

For lngRow = 1 To m - 1

strContent = ThisWorkbook.Sheets(17).Cells(lngRow, 1).Text & "|" & ThisWorkbook.Sheets(17).Cells(lngRow, 2).Text & "|" & ThisWorkbook.Sheets(17).Cells(lngRow, 3).Text & "|" & ThisWorkbook.Sheets(17).Cells(lngRow, 4).Text

strContent = strContent & vbCrLf

Print #1, strContent;

Next

strContent = ThisWorkbook.Sheets(17).Cells(m, 1).Text & "|" & ThisWorkbook.Sheets(17).Cells(m, 2).Text & "|" & ThisWorkbook.Sheets(17).Cells(m, 3).Text & "|" & ThisWorkbook.Sheets(17).Cells(m, 4).Text

Print #1, strContent;

Close #1

End With

Next ws

wb.Close savechanges:=False

fn = Dir()

Loop

Application.DisplayAlerts = True

ThisWorkbook.Sheets(17).Shapes.Range(Array("TextBox 1")).Select

Selection.Text = ThisWorkbook.Sheets(17).Range("I1").Text

ThisWorkbook.Sheets(17).Range("I1").Select

Selection.ClearContents

End Sub























Private Sub CommandButton5_Click() '批量提取数据————5

Dim wb As Workbook

Dim ws As Worksheet

Dim fn, fp

Dim i&, j&, k&, n&, m&, l&, o&

fp = ThisWorkbook.Path & "\1待处理文件\"

fn = Dir(fp & "*.xl*")

n = 2

Do While fn <> ""

Set wb = Workbooks.Open(fp & fn)

For Each ws In wb.Worksheets

With ws

On Error Resume Next

ActiveWorkbook.Sheets(1).Range("A:D").Copy

ThisWorkbook.Sheets(17).Range("A:D").PasteSpecial Paste:=xlPasteValues

For i = 250 To 1 Step -1

   If ThisWorkbook.Sheets(17).Cells(i, 4).Text Like "0" Or ThisWorkbook.Sheets(17).Cells(i, 4).Text Like "" Then

  Cells(i, 4).EntireRow.Delete

   End If

Next

For i = 250 To 1 Step -1

      If ThisWorkbook.Sheets(17).Cells(i, 3).Text Like "62*" Or ThisWorkbook.Sheets(17).Cells(i, 3).Text Like "8001000*" Then

      Else

       Cells(i, 3).EntireRow.Delete

       End If

   Next

Columns("D:D").NumberFormatLocal = "G/通用格式"

Columns("A:D").Select

Selection.Replace What:=" ", Replacement:=""

For k = 1 To j

Cells(k, 1) = k

Next

ActiveWorkbook.Sheets(1).Range("A1").Copy

ThisWorkbook.Sheets(17).Range("I1").PasteSpecial Paste:=xlPasteValues

Selection.Paste

ThisWorkbook.Sheets(17).Range("I1").Select

ThisWorkbook.Sheets(17).Range("I1").Replace What:=" ", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="普宁市大坝镇", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="大坝镇", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="教师", Replacement:=""

ThisWorkbook.Sheets(17).Range("I1").Replace What:="中学*", Replacement:="中学"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="学校*", Replacement:="小学"

ThisWorkbook.Sheets(17).Range("I1").Replace What:="小学*", Replacement:="小学"



ThisWorkbook.Sheets(16).Cells(n, 13) = ThisWorkbook.Sheets(17).Range("I1")

ThisWorkbook.Sheets(16).Cells(n, 15) = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets(17).[D:D])

ThisWorkbook.Sheets(16).Cells(n, 14) = Application.WorksheetFunction.Count(ThisWorkbook.Sheets(17).[D:D])

End With

Next ws

ActiveWorkbook.Saved = True

wb.Close savechanges:=True

fn = Dir()

n = n + 1

Loop

ThisWorkbook.Sheets(17).Shapes.Range(Array("TextBox 1")).Select

Selection.Text = ThisWorkbook.Sheets(17).Range("I1").Text

ThisWorkbook.Sheets(17).Range("I1").Select

Selection.ClearContents



ThisWorkbook.Sheets(16).Range("I2:L30").Copy

ThisWorkbook.Sheets(17).Range("F10").PasteSpecial Paste:=xlPasteValues

ThisWorkbook.Sheets(17).Range("F9") = "检索"

ThisWorkbook.Sheets(17).Range("G9") = "单位"

ThisWorkbook.Sheets(17).Range("H9") = "人数"

ThisWorkbook.Sheets(17).Range("I9") = "金额"

End Sub