0

我想将一些带有标题的列从工作表复制到另一个。我创建了一个数组来查找所需的不同标题，因此我可以将整个列复制并粘贴到新选项卡中。我知道我在某处有错误，因为我遇到了类型不匹配错误，可能还有其他类型。有人可以看看我错过了什么/有什么问题吗？

Dim rngCell As Range
Dim strHeader() As String
Dim intColumnsMax As Integer

Sheets.Add.Name = "Material Master"
Sheets.Add.Name = "BOM"

intColumnsMax = Sheets("HW Zpure Template").UsedRange.Columns.Count
ReDim strHeader(1 To intColumnsMax)

strHeader(1) = "MATERIAL"
strHeader(2) = "MATERIAL TYPE"
strHeader(3) = "MATERIAL DESCRIPTION"

For Each rngCell In Rows(4)
    For i = 1 To intColumnsMax
        If strHeader(i) = rngCell.Value Then
            rngCell.EntireColumn.Copy
                Sheets("Material Master").Select
                ActiveSheet.Paste Destination:=Worksheets("Material Master").Cells(1, i)
                Sheets("HW Zpure Template").Select
        End If
    Next i
Next
4

2 回答 2

0

Using the Find() method is a very efficient way of finding the data you want. Below are a few suggestions to optimize your existing code.

Dim rngCell As Range
Dim strHeader() As String
Dim intColumnsMax As Integer
Dim i As Integer

Sheets.Add.Name = "Material Master"
Sheets.Add.Name = "BOM"

'Quick way to load a string array
'This example splits a comma delimited string.
'If your headers contain commas, replace the commas in the next line of code
'with a character that does not exist in the headers.
strHeader = Split("MATERIAL,MATERIAL TYPE,MATERIAL DESCRIPTION", ",")

'Only loop through the headers needed
For i = LBound(strHeader) To UBound(strHeader)
    Set rngCell = Sheets("HW Zpure Template").UsedRange.Find(What:=strheader(i), LookAt:=xlWhole)
    If Not rngCell Is Nothing Then

        'Taking the intersection of the used range and the entire desired column avoids
        'copying a lot of unnecessary cells.
        Set rngCell = Intersect(Sheets("HW Zpure Template").UsedRange, rngCell.EntireColumn)

        'This method is more memory consuming, but necessary if you need to copy all formatting
        rngCell.Copy Destination:=Worksheets("Material Master").Range(rngCell.Address)

        'This method is the most efficient if you only need to copy the values
        Worksheets("Material Master").Range(rngCell.Address).Value = rngCell.Value
    End If
Next i
于 2014-11-23T06:05:00.660 回答
0

我更喜欢使用Application.Match来定位特定的列标题标签，而不是循环通过它们试图找到匹配项。为此，我对您的代码进行了大量修改。

Dim c As Long, v As Long, vHDRs As Variant
Dim s As Long, vNWSs As Variant, wsMM As Worksheet

vHDRs = Array("MATERIAL", "MATERIAL TYPE", "MATERIAL DESCRIPTION")
vNWSs = Array("Material Master", "BOM")

For v = LBound(vNWSs) To UBound(vNWSs)
    For s = 1 To Sheets.Count
        If Sheets(s).Name = vNWSs(v) Then
            Application.DisplayAlerts = False
            Sheets(s).Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next s
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = vNWSs(v)
Next v

Set wsMM = Sheets("Material Master")
With Sheets("HW Zpure Template")
    For v = LBound(vHDRs) To UBound(vHDRs)
        If CBool(Application.CountIf(.Rows(4), vHDRs(v))) Then
            c = Application.Match(vHDRs(v), .Rows(4), 0)
            Intersect(.UsedRange, .Columns(c)).Copy _
              Destination:=wsMM.Cells(1, Application.CountA(wsMM.Rows(1)) + 1)
        End If
    Next v
End With
Set wsMM = Nothing

如果我错了，请纠正我，但您的代码似乎正在寻找第 4 行中的列标签。这就是我在上面使用的，但如果该假设不正确，那么修复应该是不言而喻的。我还将复制的列堆叠到右侧的第一个可用列中。您的代码可能已将它们放在原始位置。

当您运行上述程序时，请注意，它将删除名为Material Master或BOM的工作表，而不要求插入其自己的这些名称的工作表。鉴于此，最好在原始副本上运行。

于 2014-11-23T03:51:41.783 回答