According to an excel sheet split into a plurality of conditions and merging a plurality of sheet sheet sheet sheet

This example describes how a sheet under the conditions split into a plurality of sheets in excel. Note: Many friends in sheets (i) .delete this code mistakes, pay attention to the following first steps to split the data sheet name as "data source", not when you sheet1 this new workbook. Manually changed to "data source" button. Or get the code in the "Data Source" you have to change the source worksheet "Sheet1" is also OK

Under CFGZB ()

    Dim myRange As Variant

    Dim myArray

    Dim titleRange As Range

    Dim title As String

    Dim columnNum As Integer

    myRange = Application.InputBox (prompt: = " Please select the title line: " , Type: = 8 )

    myArray = WorksheetFunction.Transpose(myRange)

    TitleRange SET = Application.InputBox (prompt: = " Choose split the header must be the first row, and a cell, such as:" name " ," , the Type: = . 8 )

    title = titleRange.Value

    columnNum = titleRange.Column

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Dim i&, Myr&, Arr, num&

    Dim d, k

    For i = Sheets.Count To 1 Step -1

        If Sheets(i).Name <> "Sheet1" Then
             Sheets(i).Delete

        End If

    Next i

    Set d = CreateObject("Scripting.Dictionary")

    Myr = Worksheets("Sheet1").UsedRange.Rows.Count

    Arr = Worksheets("Sheet1").Range(Cells(2, columnNum), Cells(Myr, columnNum))

    For i = 1 To UBound(Arr)

        d(Arr(i, 1)) = ""

    Next

    k = d.keys

    For i = 0 To UBound(k)

        Set conn = CreateObject("adodb.connection")

        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName

        Sql = "select * from [Sheet1$] where " & title & " = '" & k(i) & "'"

        Worksheets.Add after:=Sheets(Sheets.Count)

        With ActiveSheet

            .Name = k(i)

            For num = 1 To UBound(myArray)

                .Cells(1, num) = myArray(num, 1)

            Next num

            .Range("A2").CopyFromRecordset conn.Execute(Sql)

        End With

        Sheets(1).Select

        Sheets(1).Cells.Select

        Selection.Copy

        Worksheets(Sheets.Count).Activate

        ActiveSheet.Cells.Select

        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False

        Application.CutCopyMode = False

    Next i

    conn.Close

    Set conn = Nothing

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

End Sub

 

1. To merge the files in the same folder, copied like (ps: best not to directly manipulate the original data file, to avoid the operation fails, data loss)

2. Create a "merger .xlsx" in this directory

3. Double-click to open the "merger .xlsx"

4. Press ALT + F11 simultaneously

Option Explicit

Sub mergeonexls () 'combined with multiple sheets designated workbook

On Error Resume Next

Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet

Dim t As Workbook, ts As Worksheet, l As Integer, h As Long

Application.ScreenUpdating = False

Application.DisplayAlerts = False

x = Application.GetOpenFilename (FileFilter: = ". Excel files (* .xls; * .xlsx), * xls; * .xlsx, all files (* *), * *..", Title: = "Excel Select" , MultiSelect: = True)

Set t = ThisWorkbook

Set ts = t.Sheets (1) 'were combined to specify the sheet, this is the first sheet

l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column

For Each x1 In x

If x1 <> False Then

 Set w = Workbooks.Open(x1)

 Set wsh = w.Sheets (1) 'were combined to specify the desired worksheet, here is the first sheet

 h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row

 If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then

 wsh.UsedRange.Copy ts.Cells(1, 1)

 Else

 wsh.UsedRange.Copy ts.Cells(h + 1, 1)

 End If

 w.Close

End If

Next

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

Sub mergeeveryonexls () 'in the sheet corresponding to the plurality of sequentially merged into a workbook sheet in this workbook, i.e., corresponding to the first sheet incorporated into the first, second corresponds to the second combined ......

On Error Resume Next

Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet

Dim t As Workbook, ts As Worksheet, i As Integer, l As Integer, h As Long

Application.ScreenUpdating = False

Application.DisplayAlerts = False

x = Application.GetOpenFilename (FileFilter: = ". Excel files (* .xls; * .xlsx), * xls; * .xlsx, all files (* *), * *..", Title: = "Excel Select" , MultiSelect: = True)

Set t = ThisWorkbook

For Each x1 In x

If x1 <> False Then

 Set w = Workbooks.Open(x1)

 For i = 1 To w.Sheets.Count

If i > t.Sheets.Count Then t.Sheets.Add After:=t.Sheets(t.Sheets.Count)

 Set ts = t.Sheets(i)

 Set wsh = w.Sheets(i)

 l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column

 h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row

 If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then

 wsh.UsedRange.Copy ts.Cells(1, 1)

 Else

 wsh.UsedRange.Copy ts.Cells(h + 1, 1)

 End If

 Next

 w.Close

End If

Next

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

　　

 Source: https: //blog.csdn.net/qq_38545713/article/details/82500483