創建動態命名的Workseet並根據單元格值移動整個行

Question

本論壇的長期用戶，首次請求VBA幫助。仍然認爲自己是VBA的初學者。

我需要通過將單個工作表（「主」（13,000行至1,000,000行之間））中的行拆分爲新的工作表來使每日批處理文件更有意義。當這個文件每天被處理時，我的要求是我們可以根據列A中的「記錄類型」單元來移動行。

「記錄類型」例如「25」或「41」或「ZA」每個都可以有3個填充列，而記錄類型「26」可以填充30個......因此移動整行是非常重要的。

我在這方面的能力和知識受到限制，並研究了很多關於如何移動行（或行內單元格範圍）的例子，但這些例子僅限於靜態選項，如YES/NO，PAID/NOT支付。

因此，在總結，我需要： 1.創建在列A（「記錄類型」中的「主」） 2.將整行由「主」每個不同的記錄一個新的工作表中隨後創建的工作表第2行。

這裏是我的嘗試是有點創建新的工作表（雖然我必須禁用錯誤處理而無法運行的腳本 - 要踩通）

Sub breakout1() 

Workbooks(1).Activate 

Dim lastCol As Integer 
Dim LastRow As Long 
Dim x As Long 
Dim rng As Range 
Dim Rng1 As Range 
Dim Rng2 As Range 
Dim Rng3 As Range 
Dim SheetNameArray 
Dim fn As WorksheetFunction 
Dim CalcSetting As Integer 
Dim newsht As Worksheet 

Set fn = Application.WorksheetFunction 

With Application 
CalcSetting = .Calculation 
.Calculation = xlCalculationManual 
.ScreenUpdating = False 
End With 

With ActiveSheet 
Set rng = .UsedRange 
Set Rng1 = Intersect(rng, .Range("A:A")) 
lastCol = rng.Column + rng.Columns.Count - 1 

.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _ 
CopyToRange:=.Cells(1, lastCol + 2), Unique:=True 

Set Rng2 = Intersect(.Columns(lastCol + 2).CurrentRegion, _ 
.Rows("2:" & Rows.Count)) 

ReDim SheetNameArray(1 To Rng2.Cells.Count) 
SheetNameArray = fn.Transpose(Rng2) 
.Columns(lastCol + 2).Clear 

For x = LBound(SheetNameArray) To UBound(SheetNameArray) 
    On Error Resume Next 
    Set newsht = ThisWorkbook.Sheets(CStr(SheetNameArray(x))) 
     If Err <> 0 Then 
      Worksheets.Add 
      ActiveSheet.Name = CStr(SheetNameArray(x)) 
      Err.Clear 
     End If 
    'On Error GoTo 0 
     'rng.AutoFilter Field:=1, Criteria1:=SheetNameArray(x) 
     'Set Rng3 = Intersect(rng, .Cells.SpecialCells(xlCellTypeVisible)) 
     'Rng3.Copy Workbooks(1).Sheets(CStr(SheetNameArray(x))).Range("A1") 
     'rng.AutoFilter 
Next x 
End With 
Range("A1").Select 
Application.Calculation = CalcSetting 

End Sub 

Answer 1

我沒有關注你的真實目標，我無法從你的描述中理解

但這裏是你的代碼的重構，對創建和/或填充後的唯一值在「基地」片（SE代碼來設置它正確）什麼發現列「A

Option Explicit 

Sub breakout2() 

Dim x As Long 
Dim rng As Range 
Dim SheetNameArray As Variant 
Dim CalcSetting As Integer 
Dim newsht As Worksheet, BaseSht As Worksheet 

With Application 
    CalcSetting = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
End With 

Set BaseSht = ThisWorkbook.Sheets("breakout") '<== choose "base" sheet 
'Set BaseSht= Workbooks(1).ActiveSheet '<== this would activate the first workbook opend in current excel session. is it the one you actually want? 

With BaseSht 
    Set rng = .UsedRange 
    SheetNameArray = GetSheetNames(rng, 1, 2) 

    For x = LBound(SheetNameArray) To UBound(SheetNameArray) 
     Set newsht = SetSheet(CStr(SheetNameArray(x))) 

     rng.AutoFilter Field:=1, Criteria1:=SheetNameArray(x) 
     Intersect(rng, .Cells.SpecialCells(xlCellTypeVisible)).Copy Parent.Sheets(CStr(SheetNameArray(x))).Range("A1") 
     rng.AutoFilter 
    Next x 
End With 

Range("A1").Select '<=== what for? Selection is rarely a good programming habit. set and use 'range' type variables instead 

With Application 
    .Calculation = CalcSetting 
    .ScreenUpdating = True 
End With 

End Sub 


Function SetSheet(shtName As String) As Worksheet 

On Error Resume Next 
ThisWorkbook.Sheets(shtName).Activate 
If Err <> 0 Then 
    On Error GoTo 0 
    ThisWorkbook.Worksheets.Add 
    ActiveSheet.Name = shtName 
End If 
Set SetSheet = ActiveSheet 

End Function 


Function GetSheetNames(usedRng As Range, colWithSheetNames As Long, colShift As Long) As Variant 
Dim sht As Worksheet 
Dim rangeToScan As Range, rangeWithNames As Range, rngToCopyTo As Range 

With usedRng 
    Set sht = .Parent 
    Set rngToCopyTo = sht.Columns(.Columns(.Columns.Count).column + 2) 
End With 

With sht 
    Set rangeToScan = Intersect(usedRng, .Columns(colWithSheetNames)) 
    rangeToScan.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngToCopyTo, Unique:=True 
    Set rangeWithNames = .Range(rngToCopyTo.Cells(1, 1).Offset(1), .Cells(.Rows.Count, rngToCopyTo.column).End(xlUp)) 
End With 

GetSheetNames = Application.WorksheetFunction.Transpose(rangeWithNames) 
rngToCopyTo.Clear 

End Function