如何为列中的每个唯一值创建一个新的工作簿? [英] How to create a new Workbook for each unique value in a column?

问题描述

我需要为J列中的每个唯一值运行一个foreach语句.对于每个唯一名称，我想创建一个新的Excel工作簿，复制该特定名称的所有行，最后将工作簿保存为相同的唯一值.

I need to run a foreach statement for each unique value in column J. For each unique name, I want to create a new Excel Workbook copy all the rows for the specific name and finally save the workbook with the same unique value.

Sub test()
Range("A1:J17").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
Range("D1").Select
Selection.Copy
ChDir "c:\test"
ActiveWorkbook.SaveAs Filename:= _
    "c:\test\test.xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

推荐答案

我相信比我聪明的人可以告诉您如何 ReDim 数组或其他方法，但这应该可以工作.我默认将大小设置为最大1,000，但是如果要检查的行更多，则将其设置为更大.这还假定J列是需要复制到新工作簿的数据的最后一列:如果不是这种情况，请更改 ws.Range(ws.Cells(y，1)，ws.Cells(y，uCol)).将复制到 ws.Range(ws.Cells(y，1)，ws.Cells(y，WHATEVER_COLUMN)).Copy

I'm sure someone smarter than me can tell you how to ReDim the arrays or something but this should work. I set the size to 1,000 max by default but set it higher if there are more rows to check. This also assumes that column J is the last column with data that needs to be copied to the new workbook: if this isn't the case, change ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy to ws.Range(ws.Cells(y, 1), ws.Cells(y, WHATEVER_COLUMN)).Copy

Option Explicit

Sub ExportByName()
Dim unique(1000) As String
Dim wb(1000) As Workbook
Dim ws As Worksheet
Dim x As Long, y As Long, ct As Long, uCol As Long

On Error GoTo ErrHandler

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Your main worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")

'Column J
uCol = 10

ct = 0

'get a unique list of users
For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
        unique(ct) = ActiveSheet.Cells(x, uCol).Text
        ct = ct + 1
    End If
Next x

'loop through the unique list
For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1

    If unique(x) <> "" Then
        'add workbook
        Set wb(x) = Workbooks.Add

        'copy header row
        ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)

        'loop to find matching items in ws and copy over
        For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
            If ws.Cells(y, uCol) = unique(x) Then

                'copy full formula over    
                'ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1)

                'to copy and paste values
                ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
                wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)

            End If
        Next y

        'autofit
        wb(x).Sheets(1).Columns.AutoFit

        'save when done
        wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x) & " " & Format(Now(), "mm-dd-yy")
        'wb(x).Close SaveChanges:=True

    Else
        'once reaching blank parts of the array, quit loop
        Exit For
    End If

Next x

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function

这篇关于如何为列中的每个唯一值创建一个新的工作簿?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！