从一个源工作表创建多个工作表或工作簿 [英] Creating multiple worksheets or workbooks from one source worksheet

问题描述

我有一个超过一千行的电子表格。唯一标识符是位于列B中的供应商ID。数据涵盖从A列到第N列。我想解析此主电子表格，并创建新的工作表或更好地，但由每个供应商ID创建新的文件/工作簿。电子表格不包含标题。供应商ID可能只有一行，或者可以有20行数据，3行数据等。最后，我想将新文件转换为.CSV格式。创建新的工作表或文件时，我希望维护源电子表格中的所有格式。数据包含，数量，日期和常规输入的字符。

我在几天前发现了以下代码，并根据需要进行了修改。我能够让它工作，但我不喜欢它如何带来的.value，我失去了日期的格式，并为最终的结果创建格式化问题。

我想构建一个足够灵活的代码，我可以修改它，在工作簿中创建多个工作表（有或没有标题），或者有足够的灵活性修改它以创建基于每个供应商ID标准（或唯一标准，如果它用于其他目的）的工作簿。我试图阻止用户根据合并工作表手动创建168个文件或工作表。

  Sub AllocatedataCSV（）
 Dim ws As Worksheet 
设置ws = Sheets（CSV Master）
 Dim LastRow As Long 
 
 LastRow = Range（B& ws.Rows.Count）.End（xlUp）.Row 
 
'如果我们没有任何数据，停止处理
如果LastRow< 2然后退出Sub 
 
 Application.ScreenUpdating = False 
 CopyDataToSheets LastRow，ws 
 ws.Select 
 Application.ScreenUpdating = True 
 End Sub 
 
 
 Sub CopyDataToSheets（LastRow As Long，src As Worksheet）
 Dim rng As Range 
 Dim cell As Range 
 Dim Series As String 
 Dim SeriesStart As Long 
 Dim SeriesLast As Long 
 
 Set rng = Range（B1：B& LastRow）
 SeriesStart = 2 
 Series = Range（B & SeriesStart）
对于每个单元格在rng 
中如果cell.Value<>系列然后
 SeriesLast = cell.Row  -  1 
 CopySeriesToNewSheet src，SeriesStart，SeriesLast，Series 
 Series = cell.Value 
 SeriesStart = cell.Row 
 End If 
下一个
'复制最后一个系列
 SeriesLast = LastRow 
 CopySeriesToNewSheet src，SeriesStart，SeriesLast，Series 
 
 End Sub 
 
 Sub CopySeriesToNewSheet（src As Worksheet，Start As Long，Last As Long，_ 
 name As String）
 Dim tgt As Worksheet 
 
 If（SheetExists（name））Then 
 MsgBoxSheet&名称与已经存在。_ 
& 请在_ 
& 从主列表中复制数据，vbCritical，_ 
时间序列解析器
 End 
 End If 
 
 Worksheets.Add（After：= Worksheets工作表C））。name = name 
设置tgt =表（名称）
 
 
'将数据从src复制到tgt 
 tgt.Range（A1： N& Last）.Value = _ 
 src.Range（A&&N& Last）.Value 
 End Sub 
 
函数SheetExists（name As String）As Boolean 
 Dim ws As Worksheet 
 
 SheetExists = True 
 On Error Resume Next 
设置ws =表格（名称）
如果ws不是，然后
 SheetExists = False 
如果
结束函数
  

解决方案

要复制数据和格式，请更改：

  tgt.Range A1：N& Last）.Value = _ 
 src.Range（A& Start&N& Last）.Value 
  

to：

  src.Range（A 我来了p;开始& ：N&最后）。复制
 tgt.Range（A1）。PasteSpecial xlPasteAll 
  

将复制的数据复制到新工作簿中：

  Sub CopySeriesToNewSheet（src As Worksheet，Start As Long，Last As Long，_ 
 name As String）
 
 Dim wb As Workbook：Set wb = Workbooks.Add 
 Dim tgt As Worksheet 
 
 Set tgt = wb.Sheets（1） 
 tgt.name = name 
 
 src.Range（A&&N& Last）.Copy 
 tgt.Range（A1： N& Last）.PasteSpecial xlPasteAll 
 wb.SaveAs name 
 wb.Close 
 End Sub 
  

更新在评论中回答问题

如果源代码系列只有一行，粘贴的结果将不正确这可以通过粘贴到单个单元格来解决，所以

tgt.Range（A1：N& Last）.PasteSpecial xlPasteAll

成为

tgt.Range（A1 ）.PasteSpecial xlPasteAll

我已经更新了我的代码，以反映这一变化。

这也可以在原始代码中解决：

  tgt.Range（A1：N&（1 +最后开始））Value = _ 
 src.Range（A&开始&：N& Last）.Value 
  

I have a spreadsheet with over a thousand rows. The unique identifier is the vendor ID which is located in column B. The data covers from column A to column N. I want to parse this master spreadsheet and create new worksheets or better yet create a new file/workbook by each vendor ID. The spreadsheet does not contain headers. A vendor ID may just have one row or it can have 20 rows of data, 3 rows of data, etc. Lastly, I would like to convert the new file into .CSV format. When creating the new worksheets or files I would like the maintain all the formats from the source spreadsheet. The data contains, amounts, dates, and regular input of characters.

I found the below code on-line a few days ago and modified it for my needs. I was able to get it to work but I do not like how it brings over the .value and I lose the format of the dates and it creates formatting issues for the end result.

I would like to build a code flexible enough where I can modify it to create multiple worksheets within the workbook (with or without headers) or have it flexible enough where I can modify it to create workbooks based off of each vendor ID criteria (or unique criteria if it is used for other purposes). I'm trying to prevent for a user to have to create 168 files or worksheets manually based off of a consolidated worksheet.

Sub AllocatedataCSV()
    Dim ws As Worksheet
    Set ws = Sheets("CSV Master")
    Dim LastRow As Long

    LastRow = Range("B" & ws.Rows.Count).End(xlUp).Row

    ' stop processing if we don't have any data
    If LastRow < 2 Then Exit Sub

    Application.ScreenUpdating = False
    CopyDataToSheets LastRow, ws
    ws.Select
    Application.ScreenUpdating = True
End Sub


Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
    Dim rng As Range
    Dim cell As Range
    Dim Series As String
    Dim SeriesStart As Long
    Dim SeriesLast As Long

    Set rng = Range("B1:B" & LastRow)
    SeriesStart = 2
    Series = Range("B" & SeriesStart)
    For Each cell In rng
        If cell.Value <> Series Then
            SeriesLast = cell.Row - 1
            CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
            Series = cell.Value
            SeriesStart = cell.Row
        End If
    Next
    ' copy the last series
    SeriesLast = LastRow
    CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series

End Sub

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
                                                        name As String)
    Dim tgt As Worksheet

    If (SheetExists(name)) Then
        MsgBox "Sheet " & name & " already exists. " _
        & "Please delete or move existing sheets before" _
        & " copying data from the Master List.", vbCritical, _
        "Time Series Parser"
        End
    End If

    Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
    Set tgt = Sheets(name)


    ' copy data from src to tgt
    tgt.Range("A1:N" & Last).Value = _
    src.Range("A" & Start & ":N" & Last).Value
End Sub

Function SheetExists(name As String) As Boolean
    Dim ws As Worksheet

    SheetExists = True
    On Error Resume Next
    Set ws = Sheets(name)
    If ws Is Nothing Then
       SheetExists = False
    End If
End Function

解决方案

To copy data and formatting, change:

tgt.Range("A1:N" & Last).Value = _
src.Range("A" & Start & ":N" & Last).Value

to:

src.Range("A" & Start & ":N" & Last).Copy
tgt.Range("A1").PasteSpecial xlPasteAll

To put the copied data into a new workbook:

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
                                                        name As String)

    Dim wb As Workbook : Set wb = Workbooks.Add
    Dim tgt As Worksheet

    Set tgt = wb.Sheets(1)
    tgt.name = name

    src.Range("A" & Start & ":N" & Last).Copy
    tgt.Range("A1:N" & Last).PasteSpecial xlPasteAll
    wb.SaveAs name
    wb.Close
End Sub

UPDATE to answer question in comment

If a source series has only one row, the pasted result will be incorrect. This can be resolved by pasting onto a single cell, so

tgt.Range("A1:N" & Last).PasteSpecial xlPasteAll

becomes

tgt.Range("A1").PasteSpecial xlPasteAll

I've updated my code above to reflect this change.

This can also be resolved in the original code:

tgt.Range("A1:N" & (1+Last-Start)).Value = _
src.Range("A" & Start & ":N" & Last).Value

这篇关于从一个源工作表创建多个工作表或工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！