Copy specific Excel cells to new sheet with VBA Loop

[CMPaccess]

Hi all,

I have read a few posts similar to what I'm trying to acheive but without anyone actualy seeming to come up with an answer.

The problem I have is :--

Sheet 1 contains all my report data.

I want to strip certain values/cells into a new sheet to for a table.

I want to do this by specifying certain criteria. For example if Cell a1 = "A" then copy cells etc etc
if cell a1 doesn't = "A" then move to the next row etc.

I have this code thus far

Sub MemberSchedule()
'On Error GoTo Err_MemberSchedule

    'check to see if worksheet with foldername exists
    Dim FldWS As Worksheet
    Dim intCount As Integer
    Dim ShtName As String
    Dim ShtDate As String
    Dim schedSheet As Worksheet
    Dim reportSheet As Worksheet
    
    ShtDate = Date
    ShtDate = Replace(ShtDate, "/", "")
    
    ShtName = "MemberSchedule " + ShtDate
    Worksheets.Add
    ActiveSheet.name = ShtName
    MsgBox ShtName & " has been added"
    Set schedSheet = ActiveSheet
    
    'Format Sheet Style here''''''''''''''''''
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Mark"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Section Size"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "No. Off"
    Range("B:B").Select
    Selection.ColumnWidth = 15
            
    Sheets("Report").Select
    Set reportSheet = ActiveSheet
    
    Range("i:i").Select
    Dim PartNm As String
    Dim PartMk As String
    Dim SectSize As String
    Dim MemCount   As Integer
    ' Look for Beams
    PartNm = "Rectangular Beams"
    With reportSheet.Range("i2:i500")
        Set c = .Find(PartNm, LookIn:=xlValues)
        If c Is Nothing Then
                MsgBox ("No Beams Found")
        Else
            Do
                PartMk = c.offSet(0, 16).Formula
                SectSize = c.offSet(0, 1).Formula
                Dim nLastRow As Long
                Dim nFirstRow As Long
                Dim ncol As Integer
                nLastRow = schedSheet.Cells.Find(what:="*", _
                    searchdirection:=xlPrevious, _
                    searchorder:=xlRows).row + 1
                schedSheet.Range("A" & nLastRow) = PartMk
                schedSheet.Range("B" & nLastRow) = SectSize
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
Exit_MemberSchedule:
    Exit Sub

Err_MemberSchedule:

Now the problem is that the basics work. Apart from two factors.
1) It continuously loops through the data.
2) It seems to be ignoring the variable PartNm. Even though the particular cell may say columns it is still copying the data.

I would be glad of some help here to help solve these problems. Not far off just need the finishing touches.

Thanks in advance

 

[SkipVought]

Hi,

Just a few things. Dates are NUMBERS -- use FORAMT instead of trying to do a string function.

Find will LOOP back. Use previous row value to test current find row value

Sub MemberSchedule()
'On Error GoTo Err_MemberSchedule

    'check to see if worksheet with foldername exists
    Dim FldWS As Worksheet
    Dim intCount As Integer
    Dim ShtName As String
    Dim ShtDate As String
    Dim schedSheet As Worksheet
    Dim reportSheet As Worksheet
    
    Dim lRowPrev As Long
    
    ShtDate = Date
'    ShtDate = Replace(ShtDate, "/", "")  Date Value is a NUMBER -- use FORMAT
    
    ShtName = "MemberSchedule " + Format(ShtDate, "yyyymmdd")
    Set schedSheet = Worksheets.Add
    schedSheet.Name = "MemberSchedule " + Format(ShtDate, "yyyymmdd")
    MsgBox ShtName & " has been added"
    
    'Format Sheet Style here''''''''''''''''''
    Range("A1").Value = "Mark"
    Range("B1").calue = "Section Size"
    Range("C1").Value = "No. Off"
    Range("B:B").ColumnWidth = 15
            
    Set reportSheet = Sheets("Report")
    With reportSheet
        Dim PartNm As String
        Dim PartMk As String
        Dim SectSize As String
        Dim MemCount   As Integer
        ' Look for Beams
        PartNm = "Rectangular Beams"
        With .Range("i2:i500")
            Set c = .Find(PartNm, LookIn:=xlValues)
            If c Is Nothing Then
                    MsgBox ("No Beams Found")
            Else
                lRowPrev = 66000
                Do
                    PartMk = c.Offset(0, 16).Value
                    SectSize = c.Offset(0, 1).Value
                    Dim nLastRow As Long
                    Dim nFirstRow As Long
                    Dim ncol As Integer
                    nLastRow = schedSheet.Cells.Find(what:="*", _
                        searchdirection:=xlPrevious, _
                        searchorder:=xlRows).Row + 1
                    schedSheet.Range("A" & nLastRow).Value = PartMk
                    schedSheet.Range("B" & nLastRow).Value = SectSize
                    Set c = .FindNext(c)
                    If lRowPrev > c.Row Then Exit Do
                Loop While Not c Is Nothing
            End If
        End With
    End With
Exit_MemberSchedule:
    Exit Sub

Err_MemberSchedule:
End Sub

Skip,
[sub]
[red]Be Advised![/red]
The band of elderly oriental musicians, known as Ground Cover, is, in reality...
Asian Jasmine![/sub]

 

[SkipVought]

Upon reflecting on your code (trying to determine your requirements) here are a couple of other suggestions, assuming that your data is structured as a table...

Use AutoFilter on column I

Use MS Query via Data/Get External Data/New Database Query - Excel Files -- YOUR WORKBOOK -- YOUR Report Sheet...

Skip,
[sub]
[red]Be Advised![/red]
The band of elderly oriental musicians, known as Ground Cover, is, in reality...
Asian Jasmine![/sub]

 

[CMPaccess]

Skip,

Thanks for the help.

Basically the code is more or less doing what I would like but for one major problem.

The Find function does not seem to be reading the variable or linking with the FindNext function.

The Find command finds the first instance of the search variable but the FindNext seems to be ignoring the varaible and instead moving to the next row. What I have I missed ??
I have the search variable set to "Rectangular Beams" but
even if the actual cell being searched reads "Columns" the action is being carried out instead of skipping that row.

Would appreciate some help with this as this would really save us sometime ?? Thanks in advance.

Sub MemberSchedule()

    'check to see if worksheet with foldername exists if not add New Sheet
    Dim FldWS As Worksheet
    Dim intCount As Integer
    Dim ShtName As String
    Dim ShtDate As String
    Dim schedSheet As Worksheet
    Dim reportSheet As Worksheet
    
    ShtDate = Date
    
    ShtName = "MemberSchedule " + Format(ShtDate, "yyyymmdd")
    Worksheets.Add
    ActiveSheet.name = ShtName
    MsgBox ShtName & " has been added"
    Set schedSheet = ActiveSheet
    
    'Format Sheet Style here''''''''''''''''''
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Mark"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Section Size"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "No. Off"
    Range("B:B").Select
    Selection.ColumnWidth = 15
            
    Sheets("Report").Select
    Set reportSheet = ActiveSheet
    
    'Range("i:i").Select
    Dim PartNm As String
    Dim PartMk As String
    Dim SectSize As String
    Dim MemCount   As Integer
    Dim rptLastRow As Long
    ' Look for Beams
    PartNm = "Rectangular Beams"
    rptLastRow = reportSheet.Cells.Find(what:="*", _
                searchdirection:=xlPrevious, _
                searchorder:=xlRows).row
    With reportSheet.Range("i2:i500")
        Set c = .Find(PartNm, LookIn:=xlValues)
        If c Is Nothing Then
                MsgBox ("No Beams Found")
        Else
            Do
                PartMk = c.offSet(0, 16).Formula
                SectSize = c.offSet(0, 1).Formula
                Dim nLastRow As Long
                Dim nFirstRow As Long
                Dim ncol As Integer
                nLastRow = schedSheet.Cells.Find(what:="*", _
                    searchdirection:=xlPrevious, _
                    searchorder:=xlRows).row + 1
                'Cells(nLastRow, "A").Select
                'Selection.Formula = PartMk
                'Selection.offSet(0, 1).Formula = SectSize
                schedSheet.Range("A" & nLastRow) = PartMk
                schedSheet.Range("B" & nLastRow) = SectSize
                'End With
                'Sheets("Report").Activate
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.row < rptLastRow
        End If
        schedSheet.Select
        schedSheet.Range("a1").Select
        
    End With
Exit_MemberSchedule:
    Exit Sub

Err_MemberSchedule:
    MsgBox err.Description
    Resume Exit_MemberSchedule
End Sub