excel 數據拆分合併

Sub 工作薄間工作表合併() Dim FileOpen Dim X As IntegerApplication.ScreenUpdating = FalseFileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合併工作薄")X = 1While X <= UBound(FileOpen)Workbooks.Open Filename:=FileOpen(X)Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)X = X + 1WendExitHandler:Application.ScreenUpdating = TrueExit Suberrhadler: MsgBox Err.DescriptionEnd SubSub 合併當前工作簿下的所有工作表()Application.ScreenUpdating = FalseFor j = 1 To Sheets.Count If Sheets(j).Name <> ActiveSheet.Name Then X = Range("A65536").End(xlUp).Row + 1 Sheets(j).UsedRange.Copy Cells(X, 1) End IfNextRange("B1").SelectApplication.ScreenUpdating = TrueMsgBox "當前工作簿下的全部工作表已經合併完畢！", vbInformation, "提示"End Sub//拆分Sub xxx()Dim reg As RangeDim i As LongDim j As LongDim x, pth As Stringpth = ThisWorkbook.Path For i = 2 To 34082 Step 1999 Set reg = Nothing Set reg = Sheets("Sheet1").Rows(i & ":" & i + 1998) x = Sheets("Sheet1").Cells(i, 1) & "" Sheets.Add.Name = x Sheets(x).[A1] = Sheets("Sheet1").[A1] Sheets(x).[B1] = Sheets("Sheet1").[B1] Sheets(x).[C1] = Sheets("Sheet1").[C1] reg.Copy Sheets(x).Rows(2) Sheets(x).Copy Application.DisplayAlerts = False With ActiveWorkbook .SaveAs Filename:=pth & "" & "PW30_20180207_" & x & ".xlsx" .Close End With ThisWorkbook.Sheets(x).Delete Application.DisplayAlerts = True NextEnd Sub

推薦閱讀：