使用VBA將資料拆分為多個作業表

目標是根據在 1 列中找到的唯一值將我的原始資料拆分為新作業表。我發現以下 VBA 代碼可以滿足我的需求，但是我將使用它的客戶有一個鎖定的 excel“作業簿”，我無法更改原始資料列的順序。在這種情況下，此 VBA 代碼使用 A 列，但我的目標列是 C。

新作業表似乎也以目標資料的名稱命名，但我想知道如何更改它，以便我可以為作業表名稱指定一個單元格。

問題 1：我可以更改此代碼的哪一部分以使目標列 C 而不是 A。 問題 2：如何將 .name 部分更改為每張紙上 AF2 中的值？

Sub parse_data()
Dim xRCount As Long
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A1:AD1"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
    Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
    Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
    Set xNSht = Nothing
    Set xNSht = Worksheets(CStr(xCol.Item(I)))
    If xNSht Is Nothing Then
        Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
        xNSht.Name = CStr(xCol.Item(I))
    Else
        xNSht.Move , Sheets(Sheets.Count)
    End If
    xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
    xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate

結束子

編輯以包括我需要使用的客戶模板 https://www.dropbox.com/scl/fi/qb9484lmdyeo1aieqlb4m/HDTemplate.xlsx?dl=0&rlkey=6dlt1nlo8lehmnpl8cdipwbkp

uj5u.com熱心網友回復：

更新 我很確定我的第一個答案應該在正常設定下作業，這讓我覺得還有其他事情發生。但是，如果您只需要對列進行排序，請考慮使用此宏來創建新作業表。根據記錄，這是非常低效的開始。您可以使用資料透視表、過濾器功能或可能有很多其他選項來執行您需要的任何操作。但無論如何....

Sub fixYourData()

Dim tempWS As Worksheet, pullWs As Worksheet, rNum As Long
    pullWs = ActiveSheet
    rNum = pullWs.Cells(Rows.Count, 1).End(xlUp).Row
    Set tempWS = Worksheets.Add
With tempWS
    .Range("A1:A" & rNum).Value = xSht.Range("C1:C" & rNum).Value
    .Range("B1:B" & rNum).Value = xSht.Range("B1:B" & rNum).Value
    .Range("C1:C" & rNum).Value = xSht.Range("A1:A" & rNum).Value
    .Range("D1:AD" & rNum).Value = xSht.Range("D1:AD" & rNum).Value
End With

Call parse_data '<--- will run your original macro

End Sub

第一個答案 請參閱下面的代碼更改和對您的問題的評論。

Sub parse_data()





Dim xRCount As Long
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A1:AD1"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
    Call xCol.Add(xSht.Cells(I, 3).Text, xSht.Cells(I, 3).Text) '<---Q1 here
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
    Call xSht.Range(xTitle).AutoFilter(3, CStr(xCol.Item(I))) '<---Q1 here
    Set xNSht = Nothing
    Set xNSht = Worksheets(CStr(xCol.Item(I)))
    If xNSht Is Nothing Then
        Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
        
    Else
        xNSht.Move , Sheets(Sheets.Count)
    End If
    xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
    xNSht.Columns.AutoFit
    xNSht.Name = xNSht.Range("AF2").Value ' <-- Q2 here
    
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub

標籤：擅长 vba

上一篇：同一單元格中的excel資料驗證多項選擇以逗號分隔

下一篇：洗掉表中的過濾行而不是整行