Question

此论坛的长期用户，首先请求VBA帮助。仍然认为自己是VBA的初学者。

我需要通过分解单个工作表中的行来使每日批处理文件更有意义 - ＆＃34; Main＆＃34; （在13,000到1,000,000行之间）到新的工作表中。由于每天处理此文件，我的要求是我们可以根据＆＃34;记录类型＆＃34;移动行。 A栏中的单元格。

＆＃34;记录类型＆＃34;例如＆＃34; 25＆＃34;或＆＃34; 41＆＃34;或＆＃34; ZA＆＃34;可能每个都有3个填充列，而记录类型＆＃34; 26＆＃34;可能有30个填充...因此整个行移动很重要。

我的能力和知识在这里受到限制，并研究了很多关于如何移动行（或一行中的一系列单元格）的例子，但这些仅限于静态选项，例如YES / NO，PAID / NOT PAID 。

总而言之，我需要： 1.为A列中的每个不同记录创建一个新工作表（＆＃34;记录类型＆＃34;在＆＃34; Main＆＃34;） 2.从＆＃34; Main＆＃34;移动整行。随后在第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

我没有专注于你无法从你的描述中理解的真正目标

但是这里是你的代码的重构，用于创建和/或填充以“base”表中的唯一值命名的表单（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

创建动态命名的Workseet并根据单元格值

1 个答案: