Question

这是我刚刚写完的宏，遗憾的是它似乎什么也没做，我找不到错误！我正在尝试将带有标题“Offset Acct”的列从工作表1（SAPDump）复制到工作表2（提取），这是空白的。任何人都可以看到我解释为什么这不起作用？相当新的VBA，所以它可能是一个简单的解决方案。干杯

Sub ExtractData()

' Define sheets

Dim SAPDump As Worksheet
Dim Extract As Worksheet

' Set sheets

Set SAPDump = ActiveSheet
Set Extract = ThisWorkbook.Sheets("Extract")

' Define row and column counters

Dim r As Long
Dim c As Long

' Set last non-empty column

Dim lastCol As Long
lastCol = SAPDump.Cells(1, Columns.Count).End(xlToLeft).Column

' Set last non-empty row

Dim lastRow As Long
lastRow = SAPDump.Cells(Rows.Count, "A").End(xlUp).row

' Look a all columns
For c = 1 To c = lastCol
    ' Examine top column
    If SAPDump.Cells(1, c).Value = "Offset Acct" Then
        ' Loop round all rows
        For r = 1 To r = lastRow
            ' Copy column into A on Extract
            Extract.Cells(r, 1) = SAPDump.Cells(r, c)
        Next r
    Else

    End If

Next c

End Sub

Answer 1

您需要更改这些行：

For c = 1 To c = lastCol

    to

For c = 1 To lastCol

和

For r = 1 To r = lastRow

to

For r = 1 To lastRow

编辑：

更好的方法是：

Sub ExtractData()

    ' Define sheets
    Dim SAPDump As Worksheet
    Dim Extract As Worksheet

    'Define Heading range
    Dim rHeadings As Range
    Dim rCell As Range

    ' Set sheets
    Set SAPDump = ActiveSheet
    Set Extract = ThisWorkbook.Sheets("Extract")

    'Set Heading range.
    With SAPDump
        Set rHeadings = .Range(.Cells(1, 1), .Cells(1, Columns.Count).End(xlToLeft))
    End With

    'Look at each heading.
    For Each rCell In rHeadings
        If rCell.Value = "Offset Acct" Then
            'If found copy the entire column and exit the loop.
            rCell.EntireColumn.Copy Extract.Cells(1, 1)
            Exit For
        End If
    Next rCell

End Sub

Answer 2

该集合不确定，如何在excel宏中运行相同的内容。

要求您通过.pdf格式发送相同内容。

此致

斯大林。

使用VBA宏从Excel中的工作表中提取数据

2 个答案: