excel - 根据列将数据拆分为多个工作表
问题描述
#Modifying Question 以便更好地理解以及我想要的结果如何。
Wizhi 的回答几乎与我的问题相符！！但是需要对他的答案进行更多更改，因为哪个代码不适合我！正如他回答的那样，无需根据GCN Date工作。基于Destination Pincode完成的拆分工作。
请帮助某人帮助我根据表格格式在 Excel 工作簿中将数据拆分为多个工作表的宏代码。以下是我根据我的知识所做的解释以及我的期望是什么！
“这是我所做的工作簿”
请下载Macro_Folder并将其解压缩到您的“C”驱动器中。打开宏工作簿并按下按钮运行宏。
如果它要求更新公式，如下图所示，请选择“不更新”继续宏。
我的宏工作簿视图：
我已经完成了在单独的 Excel 工作簿中运行拆分宏的按钮选项。
文件所在的位置
当从宏工作簿自行打开并运行宏时，它会自动打开我的XD MIS 报告并开始格式化并将日期拆分为多个工作表。
XD MIS 的视图是具有整体原始数据的“主数据” 。
这是拆分主数据的自我运行宏后的视图。
我用于将数据拆分为多个工作表的代码：
Sub Spli_Data()
Dim wb As Workbook
Dim myfilename As String
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
myfilename = "C:\Macro\XD MIS Report.xlsx"
Set wb = Workbooks.Open(myfilename)
Cells.Select
Selection.EntireColumn.Hidden = False
Selection.EntireRow.Hidden = False
Columns("B:F").Select
Range("B2").Activate
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Range("D2").Activate
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Range("H2").Activate
Selection.Delete Shift:=xlToLeft
Columns("K:L").Select
Range("K2").Activate
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Range("D2").Activate
Selection.Cut
Selection.End(xlToRight).Select
Columns("K:K").Select
Range("K2").Activate
Selection.Insert Shift:=xlToRight
Selection.End(xlUp).Select
Range("K1").Select
ActiveCell.FormulaR1C1 = "Remarks"
Columns("J:J").Select
Selection.Copy
Columns("K:K").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H1").Select
ActiveCell.FormulaR1C1 = "Packing Type"
Range("H1").Select
Selection.End(xlToLeft).Select
Cells.Select
Selection.FormatConditions.Delete
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-1]C[6]:RC[6],RC[6])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R1C7:RC[6],RC[6])"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
Selection.End(xlUp).Select
Columns("A:A").Select
Range("A2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Application.CutCopyMode = False
Range("A1:L3100").Select
Range("A2").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
End With
With Selection.Font
.Name = "Calibri Light"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
Range("A2").Select
Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
拆分数据的结果我现在拥有的：
目的地 1
目的地 2
现在让我们明确一下我的要求：
- 我已经完成了格式宏并将数据拆分为多个工作表，但这不是我正在寻找的不精确的格式结果。
- 拆分应以相同的方法完成，但结果格式应类似于以下基于宏代码的格式。
- 拆分数据应位于Excel Workbook 的多张表中。不拆分为多个工作簿！
以这种格式为所有目标 Pincode 编写一个用于拆分数据的宏：
这就是我期望通过宏代码获得最终结果的方式
拆分完成后#Destination 1 样本的预期格式
#Destination 1 样本
这是我正在寻找的一个例子。对于主数据中的所有目的地都必须这样做
希望 ！！现在我的问题很清楚，以便更好地理解和容易回答。
解决方案
更新代码：
@Mark Balhoff，感谢您的宝贵意见，我总是喜欢学习并获得反馈以提高自己:)。我在代码中使用了您的输入，并对其进行了一些扩展。
此代码使用字典，因此您需要激活“ Microsoft Scripting Runtime”
- “工具”->“参考”->“Microsoft Scripting Runtime”使字典工作
拆分主数据的用户流程：
我假设用户将在图片中拆分此数据：按下按钮，它将选择第 7 列。 （我认为这部分带有 InputBox 等......是不必要的，因为您总是想按第 7 列进行过滤，所以我觉得它让最终用户感到困惑）
随着新图片/数据出现在更新的问题中，您从什么“原始数据”开始非常不清楚。我假设我们应该拆分的数据看起来像这样，正如首先说明的那样
- 第一个唯一目的地 Pincode 的输出：
- 第二个唯一目的地 Pincode 的输出：
代码：
Option Explicit
Sub Split()
Dim lr As Long
Dim lc As Long
Dim ws As Worksheet
Dim ws_new As Worksheet
Dim DestPincode As Range
Dim DestPincodeCol As Long
Dim vcol As Long
Dim vcol_value As String
Dim vcol_name As String
Dim vcol_prompt As String
Dim i As Integer
Dim DestPincode_ws_new As Range
Dim DestPincodeCol_ws_new As Long
Dim DestPincodeRow_ws_new As Long
Application.ScreenUpdating = False
'##### SETTINGS #####
Set ws = ActiveWorkbook.Worksheets("Master_Data") 'Set master data sheet
Set DestPincode = ws.Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
'####################
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Find last column in Master Data
DestPincodeCol = DestPincode.Column 'Get column number for Destination Pincode
lr = ws.Cells(ws.Rows.Count, DestPincodeCol).End(xlUp).Row 'Get last row
'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
'##### Filter based on InputBox #####
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="7", Type:=1)
If vcol <> 7 Then Exit Sub
'##### Get all the uniqe "Destination Pincodes" #####
' You need to activate "Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
Dim DestPincodeData()
Dim UniqueDestPincodeData As Object
Dim DestPinRow As Long
Set UniqueDestPincodeData = CreateObject("Scripting.Dictionary")
DestPincodeData = Application.Transpose(ws.Range(ws.Cells(1, DestPincodeCol), ws.Cells(ws.Cells(Rows.Count, DestPincodeCol).End(xlUp).Row, DestPincodeCol))) 'Get all the Destination Pincode values
For DestPinRow = 2 To UBound(DestPincodeData, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
UniqueDestPincodeData(DestPincodeData(DestPinRow)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Destination Pincodes and add to seperate workbooks #####
Dim new_wb As Workbook
Set new_wb = Application.Workbooks.Add 'Add new workbook
'Set new_wb = ActiveWorkbook
Dim DestPincodeName As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)) 'Filter range 'Set filter range
For Each DestPincodeName In UniqueDestPincodeData.Keys 'Filter through all the unique names in dictionary "UniqueDestPincodeData"
'Debug.Print "Destination Pincode: " & DestPincodeName 'Print current unique Destination Pincode name
'Filter the data based on "Destination Pincode" and Column from InputBox
With MyRangeFilter
.AutoFilter Field:=DestPincodeCol, Criteria1:=DestPincodeName, Operator:=xlFilterValues 'Filter on Destination Pincode
End With
'##### Create new workbook for the filtered data #####
'To add to new worksheet:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = DestPincodeName
Set ws_new = new_wb.Worksheets(DestPincodeName)
'##### Create template in the new workbook #####
'Building template output, row by row
ws_new.Range("A1:A7").Value = WorksheetFunction.Transpose( _
Array("*******", "TRIP NO", "TRIP DATE/TIME", "TRUCKTYPE (OWN/ATT/ADHOC)", "SEAL #", "SUPERVISOR NAME", "REMARK"))
ws_new.Range("H2:H6").Value = WorksheetFunction.Transpose( _
Array("VEHICLE NO", "VEHICLE CAPACITY", "DRIVER NAME", "DRIVER NO", "VENDOR NAME"))
Dim Top_Area_Cell_Format As Range
Set Top_Area_Cell_Format = ws_new.Range("A1:L1,A7:L7,A2:D2,E2:G2,H2:I2,J2:L2," _
& "A3:D3,E3:G3,H3:I3,J3:L3,A4:D4,E4:G4,H4:I4," _
& "J4:L4,A5:D5,E5:G5,H5:I5,J5:L5,A6:D6,E6:G6,H6:I6,J6:L6")
Application.DisplayAlerts = False
Top_Area_Cell_Format.Merge 'Merge cells
Top_Area_Cell_Format.HorizontalAlignment = xlLeft 'Make title in center
Top_Area_Cell_Format.Borders.LineStyle = xlContinuous 'Add border lines
Top_Area_Cell_Format.Font.Bold = True 'Add Bold text
ws_new.Range("A1:L1").HorizontalAlignment = xlCenter 'Make title in center
Application.DisplayAlerts = True
'##### Paste filtered data from Master_Data sheet #####
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).HorizontalAlignment = xlCenter 'Make text in center
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).EntireRow.Copy 'Copy entire row from filtered data
ws_new.Cells(8, "A").PasteSpecial xlPasteAll 'Paste all values including formats
Set DestPincode_ws_new = ws_new.Range(ws_new.Cells(8, 1), ws_new.Cells(1, ws_new.Cells(8, ws_new.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
DestPincodeCol_ws_new = DestPincode_ws_new.Column
DestPincodeRow_ws_new = ws_new.Cells(ws_new.Rows.Count, DestPincodeCol_ws_new).End(xlUp).Row
'Add total
ws_new.Cells(DestPincodeRow_ws_new + 1, "A").Value = "TOTAL"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Merge 'Merge cells
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).HorizontalAlignment = xlCenter 'Make text in center
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Font.Bold = True 'Add Bold text
'Add total values
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "I"), ws_new.Cells(DestPincodeRow_ws_new + 1, "I")).Formula = "=SUM(I9:I" & DestPincodeRow_ws_new & ")" 'Add sum for "No. of cartons"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "J"), ws_new.Cells(DestPincodeRow_ws_new + 1, "J")).Formula = "=SUM(J9:J" & DestPincodeRow_ws_new & ")" 'Add sum for "Actual weights"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Font.Bold = True 'Add Bold text
'##### Add sign boxes #####
Dim Bottom_Area_Cell_Text_Rng As String
Dim Bottom_Area_Cell_Format As String
Dim Bottom_Area_Cell_Format_rng As Range
Bottom_Area_Cell_Text_Rng = "B" & DestPincodeRow_ws_new + 2 & ":H" & DestPincodeRow_ws_new + 2
ws_new.Range(Bottom_Area_Cell_Text_Rng).Value = Array("Driver Signature", "", "Incharge Signature", "", "Security Signature", "", "REMARK")
Bottom_Area_Cell_Format = "A" & DestPincodeRow_ws_new + 2 & ":A" & DestPincodeRow_ws_new + 4 & "," _
& "B" & DestPincodeRow_ws_new + 2 & ":C" & DestPincodeRow_ws_new + 4 & "," _
& "D" & DestPincodeRow_ws_new + 2 & ":E" & DestPincodeRow_ws_new + 4 & "," _
& "F" & DestPincodeRow_ws_new + 2 & ":G" & DestPincodeRow_ws_new + 4 & "," _
& "H" & DestPincodeRow_ws_new + 2 & ":L" & DestPincodeRow_ws_new + 4
Set Bottom_Area_Cell_Format_rng = ws_new.Range(Bottom_Area_Cell_Format)
Application.DisplayAlerts = False
Bottom_Area_Cell_Format_rng.Merge 'Merge cells
Bottom_Area_Cell_Format_rng.HorizontalAlignment = xlLeft 'Make title in center
Bottom_Area_Cell_Format_rng.Borders.LineStyle = xlContinuous 'Add border lines
Bottom_Area_Cell_Format_rng.VerticalAlignment = xlTop 'Alignment of text
Bottom_Area_Cell_Format_rng.Font.Bold = True 'Add Bold text
Application.DisplayAlerts = True
'Adjust Column width
ws_new.Columns("A:L").Select
Selection.EntireColumn.AutoFit
Set ws_new = Nothing 'Reset worksheet value
Next
Application.DisplayAlerts = False
new_wb.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error Resume Next
Sheet1.ShowAllData 'remove filter
On Error GoTo 0
ws.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
工作簿链接： https ://www.dropbox.com/s/86wlv99y6wylpn8/split%20data.xlsm?dl=0
推荐阅读
- android - Android Studio USB调试手机显示错误
- python - 6类数据集的本地二进制模式python代码
- python - ModuleNotFoundError：没有名为“_future_”的模块
- javascript - 如何在 selenium Safari Capabilities 中设置默认下载目录？
- node.js - 如何更改端口号并永远运行服务？
- html - CSS：内容重叠页脚
- c++ - 编译 c++ 文件后无法运行 .exe 文件
- c++ - static_cast 是否创建了新的子对象？
- ios - 多个动画在 SwiftUI 中无法按预期工作
- java - 在 SBA-UI -Environment 中刷新 Context SBA-Client 后，显示状态为 DOWN