CODEWITHSUNDEEP
vbaexcelextract
James Baker
James Baker

Reputation: 333

Extracting data from a sheet in excel using VBA Macro

Here is the Macro I've just written out, unfortunately it doesn't seem to do anything and I can't find the error! I am trying to copy the column with the header "Offset Acct" from sheet 1 (SAPDump) to sheet 2 (Extract) which is blank. Can anyone see explain to me why this isn't working? Fairly new to VBA so it's probably an easy fix. Cheers

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

Upvotes: 0

Views: 21473

Answers (2)

stalin
stalin

Reputation: 11

The set is not sure, how to run the same within excel macro.

Request you to send the same via .pdf formate.

Regards

Stalin.

Upvotes: 0

Darren Bartrup-Cook
Darren Bartrup-Cook

Reputation: 19857

You need to change these lines:

For c = 1 To c = lastCol

    to

For c = 1 To lastCol

and

For r = 1 To r = lastRow

to

For r = 1 To lastRow

Edit:

A better way may be to do this:

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

Upvotes: 2

Related Questions