excle vba多工作簿合一、某列留汉字、插入列等代码

Sub 多合一留汉字插入列()

Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m&, h, zgx

Set sh = ActiveSheet

MyPath = ThisWorkbook.Path & "\"

MyName = Dir(MyPath & "*.xls")

Application.ScreenUpdating = False

Set sh = Sheets.Add '新插入一工作表

Cells.ClearContents

Do While MyName <> ""

If MyName <> ThisWorkbook.Name Then

With GetObject(MyPath & MyName)

h = sh.[a65536].End(xlUp).Row

'Rows(h).Insert shift:=xlUp

For Each sht In .Sheets

If IsSheetEmpty = IsEmpty(sht.UsedRange) Then

m = m + 1

If m = 1 Then

sht.[a1].CurrentRegion.Copy sh.[a1]

Else

sht.[a1].CurrentRegion.Offset(0).Copy sh.[a65536].End(xlUp).Offset(1)

End If

'Debug.Print m

'Debug.Print h

'Cells(sh.UsedRange.Rows.Count, 1) = MyName

For zgx = h To sht.UsedRange.Rows.Count + h - 1 'sht.UsedRange.Rows.Count是各个分表的行高，h是汇总表的原行高，sht.UsedRange.Rows.Count + h是现行高。

sh.Cells(zgx + 1, 1) = MyName

Next

'sh.Cells(h + 1, 1).Offset(0, 1) = "合计"

Cells(m, 8) = MyName

'Debug.Print sht.UsedRange.Rows.Count, h, sht.UsedRange.Rows.Count + h - 1

End If

Next

.Close False

End With

End If

MyName = Dir

Loop

Application.ScreenUpdating = True

test

End Sub

Sub test()

'留汉字、插入列、2、3列合并值赋予第一列

    Dim rng As Range, reg As Object

    Dim i, j

    Set reg = CreateObject("vbscript.regexp")

    With reg

        .Global = True

        .Pattern = "[\u4e00-\u9fa5]+"

    End With

      j = Range("A65536").End(xlUp).Row

    For Each rng In Range("A1:A" & Range("A65536").End(xlUp).Row)

        If reg.test(rng.Value) Then

            rng.Value = reg.Execute(rng.Value)(0)

        End If

    Next

       Columns(1).EntireColumn.Insert '在第一列前新插入一列，成为第一列

              For i = 1 To j

       Cells(i, 1) = Cells(i, 2) & Cells(i, 3)

              Next

End Sub