Question

这是一个奇怪的问题，但我会尽力做到这一点。我想浏览一个主表并创建新表（在同一工作簿中），然后找到要放入这些新表中的相应数据。例如，我要浏览主工作表，在标题中搜索es1的所有实例，从主工作表中剪切这些列，然后将其粘贴到仅用于es1数据的新工作表中。这对于除es4以外的所有情况都非常适用。这一列的数量最少，我认为这可能会导致错误。它将所有es4列都切掉没有问题，但是随后在工作表开头附近的某个地方切出了另外一列。但是，只有在主表中的es4少于大约17个实例（在15到20之间，仍在测试中）的情况下，它才会这样做。附加的列根据es4实例的数量而变化，但并不总是相同的。

我仔细检查了find函数是否未找到某些可能导致问题的es4隐藏实例。我在那里没有发现任何问题。我一直在测试es4实例的确切数量，这些实例会导致添加此新列，但是我仅将其范围缩小到15到20之间。我将继续缩小范围。 **我所做的最有说服力的测试是输出每个es4的地址。如果只有一个es4实例，则输出的地址正确。当有多个时，输出的地址始终是es4的NEXT实例。这使我认为有些变化没有意识到。但是我在其他9张纸上没有这个问题，它们都是基于相同的功能。请注意，这不仅是循环到工作表的开头，并选择带有es4的两个实例的第一列。追加的列属于保留在主表中的数据类别（未剪切并粘贴到其他表）。

'此子项创建新的工作表，并将工作表名称传递给下一个子项，从而将数据切出并 '粘贴到一张新纸上

Sub NewSheets()
'
' NewSheets Macro
' Create new sheets with proj numbers in them
'
' Keyboard Shortcut: Ctrl+p
'
    Application.ScreenUpdating = False 'Help with preventing crashing

    Dim WS As Worksheet
    Dim count As Integer
    Dim intI As Integer
    Dim intJ As Integer
    Dim projNum(1000) As String
    Dim SheetNames As Variant
    Dim projCounter As Long
    SheetNames = Array("ES1", "ES2", "ES3", "ES4", "ES5", "C1", "C2", "C3", "C4", "C5", "PD")

    Const SheetNumber = 10 '11 total but accounting for index

    'Populate array with project numbers
    For intI = 0 To Range("A2").End(xlDown).Row - 2
        projNum(intI) = Cells(intI + 2, 1).Value
        projCounter = projCounter + 1
        Next

    'Create new sheets and insert project numbers in first column
    For count = 0 To SheetNumber
        Set WS = ThisWorkbook.Sheets.Add(After:= _
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
        Range("A1").Select
        ActiveCell.FormulaR1C1 = "Project Number"

     'Fix Numbers later
            For intJ = 0 To projCounter - 1 '-1 for account for index shift
                Cells(intJ + 2, 1).Value = projNum(intJ)
                Next
        WS.Range("A1").Columns.AutoFit

        WS.Name = SheetNames(count)
        Next

    Application.Wait (Now + TimeValue("0:00:01")) 'give time to process

    'Extract Data calling from other sub and passing sheet names
     For i = 0 To SheetNumber
        Find_Header (SheetNames(i))
        Next

    'Delete blank columns
'Step1:  Declare your variables.
    Dim MyRange As Range
    Dim iCounter As Long
'Step 2:  Define the target Range.
    Set MyRange = ActiveSheet.UsedRange

'Step 3:  Start reverse looping through the range.
    For iCounter = MyRange.Columns.count To 1 Step -1

'Step 4: If entire column is empty then delete it.
       If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then
       Columns(iCounter).Delete
       End If
'Step 5: Increment the counter down
    Next iCounter

    Application.ScreenUpdating = True 'Update once everything is done running

End Sub

Sub Find_Header(SheetNames As String)

'
' Find_Header Macro
' Find headers and put columns into appropriate sheets
'
' Keyboard Shortcut: Ctrl+h
'

    Dim findValue As Range
    Dim findValueFirst As String
    Dim colCounter As Long
    Dim rowCounter As Long

    Worksheets("Project Summary").Activate 'Make sure first sheet is labeled project summary

    'Finds all instances of a string in the active sheet
    With ActiveSheet.Range("1:1")

        Set findValue = .Find(What:=SheetNames, LookAt:=xlPart, SearchOrder:=xlByColumns)

        If findValue Is Nothing Then

            MsgBox "Error. Nothing found"

            Exit Sub

        End If

        colCounter = 2  'set starting point for where to paste

        Do Until findValue Is Nothing
            findValue.Activate 'Shift to current cell
            Set findValue = .FindNext(findValue)

            ActiveCell.EntireColumn.Cut Destination:=Sheets(SheetNames).Columns(colCounter)
            Columns.AutoFit

            Application.Wait (Now + TimeValue("0:00:01")) 'give time to process

            colCounter = colCounter + 1  'increase where to paste

        Loop

    End With

End Sub

我希望es4工作表仅填充es4数据。因此，标头中具有es4实例的任何数据。实际的输出是我从表格开头附近的某处获得了es4 AS WELL AS的所有数据。

不需要的列附加到一个特定的数据集

0 个答案: