用于将主电子表格拆分为适当的单独表格的宏代码 [英] Macro code for splitting a main spreadsheet into its appropriate seperate sheet

问题描述

我有一组数据需要拆分成单独的表格。

I have a group of data that I need to split into separate sheets.

根据条件如下下面。

主页：主要指数

栏目：纪律，分学科，参考代码，姓名，日期等......（或C8：J8）

Columns: Discipline, Sub-Discipline, Ref Code, Name, Date, etc... (or C8:J8)

主页用于输入每个学科的数据。

The main page is for inputting your data for each discipline.

我需要将MAIN INDEX分成预先存在的个体基于学科的表格（C：C）。如果任何变量随时间变化，这应该会自动更新。

I need to split the MAIN INDEX into pre-existing individual sheets based on the Discipline (C:C). This should automatically update if any of the variables change over time.

如果有人能提供这样的代码，我将不胜感激。

I would appreciate if anybody can provide such a code.

提前致谢，

问候，

Steve

推荐答案

这假设标题位于MAIN INDEX表的第1行。

This assumes that headers are in row 1 of your MAIN INDEX sheet.

Sub ExportDataBaseToSheets（）



    Dim endRow As Long

    Dim sh As Worksheet

    Dim shtT As Worksheet

    Dim rF As Range'过滤器值

    Dim rD As Range的数据范围

    Dim c As Range

    Dim lCol As Long



   设置sh =表格（"MAIN INDEX"）



    lCol = 3'使用C栏¥b $ b $
    "当然最好检索上次使用的行号。
    endRow = sh.Cells（sh.Rows.Count，lCol）.End（xlUp）.Row



    '找到唯一值 - 假设标题位于第1行中$
   设置rD = sh.Range（sh.Cells（1，lCol），sh.Cells（endRow，lCol））

    rD.AdvancedFilter动作：= xlFilterCopy，copytorange：= sh.Cells（endRow + 4，lCol），唯一：=真

   设置rF = sh.Range（sh.Cells（endRow + 5，lCol），sh.Cells（sh.Rows.Count，lCol）.End（xlUp））



    '循环显示唯一值

   每个c in rF



        On Error Resume Next

        Application.DisplayAlerts = False

       工作表（c.Value）。删除

        Application.DisplayAlerts = True

        On Error GoTo 0
$


  &NBSP; &NBSP; &NBSP; '制作新作品<
  &NBSP; &NBSP; &NBSP;设置shtT = Worksheets.Add（在：= Worksheets（Worksheets.Count）之后））
  &NBSP; &NBSP; &NBSP; shtT.Name = c.Value



  &NBSP; &NBSP; &NBSP; '找到新工作表的值

  &NBSP; &NBSP; &NBSP;有rD

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .AutoFilter字段：= 1，条件1：= c.Value

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .EntireRow.Copy shtT.Range（" A1"）

  &NBSP; &NBSP; &NBSP;结束与$
  &NBSP;下一页c


$ b  &NBSP; '清理

  &NBSP; sh.Activate

  &NBSP; rD.AutoFilter

  &NBSP; rF.Offset（-1）.Resize（rF.Rows.Count + 1）。清除



结束子

Sub ExportDataBaseToSheets()

    Dim endRow As Long
    Dim sh As Worksheet
    Dim shtT As Worksheet
    Dim rF As Range 'filter values
    Dim rD As Range 'range of data
    Dim c As Range
    Dim lCol As Long

    Set sh =Sheets("MAIN INDEX")

    lCol = 3 'Use Column C

    ' of course it's best to retrieve the last used row number
    endRow = sh.Cells(sh.Rows.Count, lCol).End(xlUp).Row

    'Find the unique values - assumes that headers are in row 1
    Set rD = sh.Range(sh.Cells(1, lCol), sh.Cells(endRow, lCol))
    rD.AdvancedFilter Action:=xlFilterCopy, copytorange:=sh.Cells(endRow + 4, lCol), Unique:=True
    Set rF = sh.Range(sh.Cells(endRow + 5, lCol), sh.Cells(sh.Rows.Count, lCol).End(xlUp))

    'Loop through the unique values
    For Each c In rF

        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(c.Value).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

        'Make the new workhseet
        Set shtT = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        shtT.Name = c.Value

        'Find the values for the new worksheet
        With rD
            .AutoFilter Field:=1, Criteria1:=c.Value
            .EntireRow.Copy shtT.Range("A1")
        End With
    Next c

    'Clean up
    sh.Activate
    rD.AutoFilter
    rF.Offset(-1).Resize(rF.Rows.Count + 1).Clear

End Sub

这篇关于用于将主电子表格拆分为适当的单独表格的宏代码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！