Macro to copy cells based on the value of another cell

**neodjandre** · 09-19-2007, 08:42 AM

the data is like this:

Col A Col B

10
20
30 X
40
50
60 X

i would like a macro to copy only 30 and 60 because there is an "X" against them in column B.

i would like the macro to copy this values on the clipboard or a list with no blanks..

can anyone help? thanx

**RobynC** · 09-19-2007, 09:12 AM

This first bit of code will work providing that x is found nowehere else in the sheet except in the column next to the data you want to transfer

Sub TransferAgain()

Dim LastRow As Long
Dim nextrow As Long
Dim rWhatToFind

    LastRow = Application.WorksheetFunction.CountA(Range("A:A"))
    Cells.Find(What:="X").Activate
    rWhatToFind = ActiveCell.Address
     
    Do
        nextrow = Application.WorksheetFunction.CountA(Range("C:C")) + 1
        ActiveCell.Offset(0, -1).Copy Cells(nextrow, 3)
        Cells.FindNext(After:=ActiveCell).Activate
    Loop Until ActiveCell.Address = rWhatToFind

End Sub

This is a slightly modified version which restricts the search range to just the column next to the data so will work if x can be found elsewhere in the speardsheet.

Sub TransferData()

Dim rFindWhere As Range 'Where to look up details
Dim rFindWhat As Variant 'What to look for in range
Dim rWhatToFind
Dim LastRow As Long
Dim nextrow As Long

    LastRow = Application.WorksheetFunction.CountA(Range("A:A"))
    
    Set rFindWhere = Range(Cells(1, 2), Cells(LastRow, 2))
    rFindWhat = rFindWhere.Find(What:="X").Activate
    rWhatToFind = ActiveCell.Address
 
    Do
        nextrow = Application.WorksheetFunction.CountA(Range("C:C")) + 1
        ActiveCell.Offset(0, -1).Copy Cells(nextrow, 3)
        Cells.FindNext(After:=ActiveCell).Activate
    Loop Until ActiveCell.Address = rWhatToFind

End Sub

Just change the column references as needed.

Hope this helps, Robyn

**RobynC** · 09-19-2007, 09:13 AM

PS I have no idea how to copy values to the clipboard so can't help there, sorry

**broro183** · 09-19-2007, 10:07 AM

Hi,

Here are some bones of a macro to work with - not tested b/c I don't have excel open at the moment & I modified some previously exported macros to give the below...

Option Explicit
Sub CopyCertainInfo()
Application.ScreenUpdating = False
Dim CurrentSheet As Worksheet
dim ListSheet as worksheet
Dim EntireRangeToFilter As Range
Dim VisibleEntireRange As Range
dim r as long

set CurrentSheet = activesheet
Set EntireRangeToFilter = ActiveWorkbook.CurrentSheet.Range("a5:a100")
sheets.add 'only do this & the following line once
activesheet.name = "Summarised List"

set ListSheet =activesheet
CurrentSheet.select
'nb this does not check for filter existence but assumes that columns A & B are in an "autofilter range"
Selection.AutoFilter Field:=2, Criteria1:= "x"

	r = Listsheet.Range("A" & Rows.Count).End(xlUp).Row + 1

    Set VisibleEntireRange = EntireRangeToFilter.SpecialCells(xlCellTypeVisible)
    VisibleEntireRange.copy Listsheet.cells(1,r)

Selection.AutoFilter Field:=2
Set EntireRangeToFilter = Nothing
Set VisibleEntireRange = Nothing
Application.ScreenUpdating = True
MsgBox "done"
End Sub

I hope it works as is but if not let us know & someone should be able to help - I'm off to sleep now.

hth
Rob

**neodjandre** · 09-19-2007, 12:12 PM

Application.ScreenUpdating = False
Range("AD12:AD1012").Select
Selection.ClearContents

    Range("M11:R1512").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=4, Criteria1:="X"
    Range("M12:M1512").Select
    Selection.Copy
    Range("AD12").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
    Selection.AutoFilter
    Application.ScreenUpdating = True
    MsgBox "The accounts are listed in column AD."

Macro to copy cells based on the value of another cell

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Macro to copy cells based on the value of another cell

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions