Thread: Copying & Pasting cells based on some other cells

HI,
I have the following data :

India Australia Europe CMC
ABC 687 675 -9 -93
EFG -98 429 876 284
HIJ 98 257 479 424
LMN 709 -0.07 78248 -4892
OPQ 180 986 3910 78943

I want pick the columns heads & row heads where the intersection value is negative & paste it in different sheet. Is it possible to do through macros. I want the final output as:
A B
India EFG
Australia LMN
Europe ABC
CMC ABC
CMC LMN

Thanks

Hi rohit1086
Welcome to the Forum!
This code is in the attached and appears to do as you require

Option Explicit
Sub test()
    Dim LR As Long
    Dim LC As Long
    Dim NewLR As Long
    Dim i As Long
    Dim j As Long

    Application.ScreenUpdating = False
    Sheets("Sheet1").Cells.Copy
    Sheets("Sheet2").Range("A1").PasteSpecial
    With Sheets("Sheet2")
        .Activate
        LR = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        .Range("A2:A" & LR).Cut
        .Cells(2, LC + 2).Select
        ActiveSheet.Paste
        .Range("A2:A" & LR).Delete shift:=xlToLeft
    End With
    With Sheets("Sheet2")
        NewLR = LR + 2
        For i = 1 To LC
            For j = 2 To LR
                If Cells(j, i).Value < 1 Then
                    .Range("A" & NewLR).Value = Cells(i).Value
                    .Range("B" & NewLR).Value = Cells(j, LC + 1).Value
                    NewLR = NewLR + 1
                End If
            Next j
        Next i
        .Range("A1:A" & LR + 1).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
End Sub

Hi rohit1086
I created a worksheet from data you provided and the code was based on my perception of that. I don't know what your data looks like (I don't get the picture). I'll need to see what your data looks like to change the code. Please put it on a worksheet then attach the file. I'll be glad to look at it.

Hi jaslake,

I have attached the data in the worksheet below. The first sheet in the attachement is the original data. The second worksheet is the desired output.

Thanks

Hi rohit1086
This code is in the attached and appears to do as you require

Option Explicit
Sub test()
    Dim LR As Long
    Dim LC As Long
    Dim NewLR As Long
    Dim i As Long
    Dim j As Long

    Application.ScreenUpdating = False
    Sheets("Sheet1").Cells.Copy
    Sheets("Sheet2").Range("A1").PasteSpecial
    With Sheets("Sheet2")
        .Activate
        .Cells.UnMerge
        LR = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
    .Range("A2:A" & LR).AutoFilter Field:=1, Criteria1:=Array( _
        "ASSETS", "LIABILITIES", "="), Operator:=xlFilterValues
    .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilterMode = False
        LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
        .Range("A2:A" & LR).Cut
        .Cells(2, LC + 1).Select
        ActiveSheet.Paste
        .Columns("A:B").Delete Shift:=xlToLeft
        LR = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
    End With
    With Sheets("Sheet2")
        NewLR = LR + 4
        For i = 1 To LC
            For j = 2 To LR
                If Cells(j, i).Value < 0 Then
                    .Range("A" & NewLR).Value = Cells(2, i).Value
                    .Range("B" & NewLR).Value = Cells(j, LC).Value
                    NewLR = NewLR + 1
                End If
            Next j
        Next i
        .Range("A1:A" & LR).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
End Sub

Let me know of issues.