CODEWITHSUNDEEP
excelvba
Mido88
Mido88

Reputation: 29

Copy all data from column based on condition

I've been struggling with this problem for a whole month...

Here is the point. I've got a sheet in excel called Amounts where there are many datas listed under 10 columns from cell A2 to cell J2. The last colum can vary day to day. There are headnames above those different datas that allows me to know the type of data.

Anyway, there are many columns where the header start with the following value Amount of (date). I want to make a code that;

  1. Allows me to search automatically for all the columns'name that starts with the value Amount of
  2. Copy all of the data below (from the first data until the last one). The range of datas under each column can vary from day to day.
  3. And finally paste each of the range data copied under the column header on other sheet and in one single column (starting in cel(1,1)).

Here's how my current code looks like;

Dim cel As Range
With Sheets("Amounts")
    Worksheets("Amounts").Activate

    For Each cel In Range("A2", Range("A2").End(xlToRight)
        If cel.Value Like "Amount in USD *" Then
            cel.Offset(1).Select
            Range(Selection, Selection.End(xlDown)).Select
                        
            Selection.Copy Worksheets("Pasted Amounts").Range("A2")
        End If
    Next cel

Could you please help me with this...? I feel like the answer is so obvious like the nose in the middle of my face.

Upvotes: 1

Views: 710

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149295

Try this. I have commented the code so you should not have a problem understanding it.

Option Explicit

Sub Sample()
    Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim lRowInput As Long
    Dim lRowOutput As Long
    Dim lCol As Long
    Dim i As Long
    Dim Col As String
    
    '~~> Set your sheets here
    Set wsInput = Sheets("Amounts")
    Set wsOutput = Sheets("Pasted Amounts")
    
    With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        
        '~~> Loop through columns
        For i = 1 To lCol
            '~~> Check for your criteria
            If .Cells(2, i).Value2 Like "Amount in functional currency*" Then
                '~~> Get column name
                Col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .Range(Col & .Rows.Count).End(xlUp).Row
                
                '~~> Find the next row to write to
                If lRowOutput = 0 Then
                    lRowOutput = 2
                Else
                    lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
                End If
                
                '~~> Copy the data
                .Range(Col & "3:" & Col & lRowInput).Copy _
                wsOutput.Range("A" & lRowOutput)
            End If
        Next i
    End With
End Sub

Worth a read

  1. How to avoid using Select in Excel VBA
  2. Find Last Row in Excel

Upvotes: 1

Related Questions