使用Excel VBA，根据特定列中的唯一项目创建表格并移动数据 [英] Create Sheets and move data based on unique items in a specific column, using Excel VBA

问题描述

我熟悉编程，但不熟悉VBA或excel对象模型。我发现它非常令人沮丧的处理。

我所拥有的是单列数据列标题。根据数据类型，有一个可变数量的标题，所以我需要找到一个不总是在同一个地方的列（在所有表格中）（所以我不能硬编码）。

我想为每个姓氏创建一个工作表，最好用该名称标题，然后从原始工作表复制到每个特定工作表，所有名称为

$ b $的ROW b

到目前为止我已经有了：

  Cells.find（What：=Last_Name ：= ActiveCell，LookIn：= xlFormulas，_ 
 LookAt：= xlPart，SearchOrder = = xlByRows，SearchDirection：= xlNext，_ 
 MatchCase：= False，SearchFormat：= False）。激活
  

查找具有名称的列。我可以对列进行排序（这不是完全必要的，但手动复制部分时有帮助）。

  ActiveCell .Sort key1：= ActiveCell，Order1：= xlAscending，Header：= xlYes 
  

努力找到一种方式将独特的项目导入列表或数组或某些东西。

我知道如何使用

$创建工作表b $ b

 设置WS = Sheets.Add 
 WS.name =string name goes here
  

所以主要部分是找到一种迭代唯一名称的方式，使表单和相应的行复制到表中与该行中相同名称的工作表。

与Excel接口的任何提示可以学习VBA或任何其他方式（.Net不知何故？）将不胜感激。

解决方案

这应该让你关闭

  Sub MakeLastNameSheets（）
 
 Dim rLNColumn As Range 
 Dim rCell As Range 
 Dim sh As Worksheet 
 Dim shDest As Worksheet 
 Dim rNext作为范围
 
 Const sLNHEADER As String =Last_Name
 
设置sh = ThisWorkbook.Sheets（Sheet1）
设置rLNColumn = sh.UsedRange.Find sLNHEADER，xlValues，xlWhole）
 
'确保你找到了一些
如果没有rLNColumn是Nothing然后
'通过列中的每个单元格
对于每个rCell Intersect（rLNColumn.EntireColumn，sh.UsedRange）.Cells 
'跳过标题和空单元格
如果不是IsEmpty（rCell.Value）和rCell.Address<> rLNColumn.Address然后
'看是否已经存在一个表
 On Error Resume Next 
设置shDest = sh.Parent.Sheets（rCell.Value）
错误GoTo 0 
 
'如果不存在，使它
如果shDest是没有
设置shDest = sh.Parent.Worksheets.Add 
 shDest.Name = rCell.Value 
 End If 
 
'查找下一个可用行
设置rNext = shDest.Cells（shDest.Rows.Count，1）.End（xlUp）.Offset（1，0 ）
 
'复制并粘贴
相交（rCell.EntireRow，sh.UsedRange）.Copy rNext 
 
'重置目标表
设置shDest =没有
结束如果
下一个rCell 
结束如果
 
结束Sub 
  

最后一个结束一张在您的列表中的名称。如果你有1000个独特的姓氏，你可能会崩溃excel - 表限制在可用的内存。它不会复制标题行，但这很简单。而且它不检查非法的表单名称字符，所以如果你有任何时髦的姓氏，你可能想要清除非alpha。

I am familiar with programming, but not VBA or the excel object model. I am finding it intensely frustrating to deal with.

What I have is a single sheet of data with column headings. There are a variable number of headings depending on the type of data, so I need to find a specific column (in all sheets) that is not always in the same place (so I cannot hardcode it).

I want to create a sheet for each last name, preferably title it with that name, and then copy from the original sheet to each specific sheet, all ROWs with the name

What I have so far:

   Cells.find(What:="Last_Name", After:=ActiveCell, LookIn:=xlFormulas, _
       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
       MatchCase:=False, SearchFormat:=False).Activate

To find the column with the names. I can then sort the column (which isn't totally necessary, but it helps when doing the copying part manually.)

    ActiveCell.Sort key1:=ActiveCell, Order1:=xlAscending, Header:=xlYes

but after that I am struggling to find a way to get the unique items into a list or array or something.

I know how to create a sheet with

Set WS = Sheets.Add
WS.name = "string name goes here"

So the main part is finding a way to iterate over the unique names, making sheets and copying appropriate rows into the sheets with the same name in the sheet as in the row.

Any tips to learn VBA or any other way (.Net somehow?) of interfacing with Excel would be very appreciated.

解决方案

This should get you close

Sub MakeLastNameSheets()

    Dim rLNColumn As Range
    Dim rCell As Range
    Dim sh As Worksheet
    Dim shDest As Worksheet
    Dim rNext As Range

    Const sLNHEADER As String = "Last_Name"

    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set rLNColumn = sh.UsedRange.Find(sLNHEADER, , xlValues, xlWhole)

    'Make sure you found something
    If Not rLNColumn Is Nothing Then
        'Go through each cell in the column
        For Each rCell In Intersect(rLNColumn.EntireColumn, sh.UsedRange).Cells
            'skip the header and empty cells
            If Not IsEmpty(rCell.Value) And rCell.Address <> rLNColumn.Address Then
                'see if a sheet already exists
                On Error Resume Next
                    Set shDest = sh.Parent.Sheets(rCell.Value)
                On Error GoTo 0

                'if it doesn't exist, make it
                If shDest Is Nothing Then
                    Set shDest = sh.Parent.Worksheets.Add
                    shDest.Name = rCell.Value
                End If

                'Find the next available row
                Set rNext = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Offset(1, 0)

                'Copy and paste
                Intersect(rCell.EntireRow, sh.UsedRange).Copy rNext

                'reset the destination sheet
                Set shDest = Nothing
            End If
        Next rCell
    End If

End Sub

You'll end with one sheet for every last name in your list. If you have 1,000 unique last names, you'll probably crash excel - sheets are limited to available memory. It doesn't copy the header row, but that's easy enough. And it doesn't check for illegal sheet name characters, so if you have any funky last names, you might want to clean out the non-alpha.

这篇关于使用Excel VBA，根据特定列中的唯一项目创建表格并移动数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！