Copy rows to 2 sheets using criteria

moroformat · Jan 22, 2013

I copy data to the sheet "3" in a daily basis so the row count vary every day
depending on the date range I need. I need only the data in the rows with green
headings from sheet "3" to go the corresponding headings in sheets "1" and "2"
with the following criteria:

I need all of the rows with green headings
from sheet "3" with the word criteria "Asset" from column "BJ" copyied to the
green section of sheet "1" after clicking a button called run in sheet "1".
I
also need all of the rows with green headings from sheet "3" with the word
"criteria "Stock" from column "BJ"copyied to the green section of sheet "2"
after clicking a button called run in sheet "2".

I need the macro to also
keep the two rows of space between the green and yellow sections in sheets "1"
and "2" regardless of how many data it is copyied to the green section. In other
words I would like it if the green section autosizes so that there is always a
2-row space between the green and yellow section after the data is pasted in
sheets "1" and "2".

Thank you for your time and I would really appreciate
some assistance with this Macro.

Attached is the excel
file.

Thanks,

moroformat

gsnidow · Jan 23, 2013

moroformat, I did not see this until just before I had to leave, but I know how it is when you are in a jam, and don't know where to start. Anyhow, here is an extremely brutish, uncommented, not exactly working place for you to start. Make a copy of your workbook first then test on that. You'll be able to see that it is hard-coded to work on sheet "1" and "Asset", but if I have time tomorrow, I'll work on it a bit more. This ought to help you get started.

Code:

Sub MoveData()
    Dim arToCols(1 To 2, 1 To 12)
    Dim arFromCols(1 To 2, 1 To 12)
    Dim i As Long, j As Long, y As Long, LastRow As Long, lSkip As Long
    Dim WSTo As Worksheet
    Dim WSFrom As Worksheet
    
    Set WSFrom = ActiveWorkbook.Sheets("3")
    Set WSTo = ActiveWorkbook.ActiveSheet
    With WSTo
        For i = 1 To 12 Step 1
            arToCols(1, i) = i
            arToCols(2, i) = .Cells(8, i).Value
        Next i
    End With
    
    With WSFrom
        LastRow = .Cells(65000, 1).End(xlUp).Row
        y = 1
        For i = 1 To 100 Step 1
            For j = 1 To 12 Step 1
                If .Cells(1, i).Value = arToCols(2, j) Then
                    arFromCols(1, y) = i
                    arFromCols(2, y) = .Cells(1, i).Value
                    y = y + 1
                End If
            Next j
        Next i
    End With
    
    With WSTo
        lSkip = 0
        For i = 9 To 9 + LastRow Step 1
            If WSFrom.Cells(i - 8, 62).Value = "Asset" Then
                For y = 1 To 12 Step 1
                    For j = 1 To 12 Step 1
                        If .Cells(8, y).Value = arFromCols(2, j) Then
                            .Cells(i - lSkip, y).Value = WSFrom.Cells(i - 7, arFromCols(1, j))
                        End If
                    Next j
                Next y
            Else: lSkip = lSkip + 1
            End If
        Next i
    End With
    
End Sub

gsnidow · Jan 24, 2013

moroformat, I had a little time this morning, so I went ahead and made this work. Please ignore my previous post. Before you use this, a couple of caveats. You need to make sure all the column headings on sheet "3" *exactly* match the column headings on sheets "1" and "2". The reason is that the code looks for matches, and "NAICS" is not the same as "NAICS " (with a space). I think I had to fix one or two. Secondly, the code assumes there will *always* be *exactly* 8 blank green rows on sheets "1" and "2". If there are more data rows than there are blank target rows, the code will insert enough, and leave your two blank rows between the data and the analysis section. Once again, this is very much a brute force method, as it uses several nested loops to traverse a couple of arrays to get the job done. If you have a large amount of data, it may take a few seconds to run. Maybe someone else will provide a more elegant solution, but until/unless they do, you can try this. There is no error checking, so you can play around with it. Let us know if you encounter any bugs, or need help tweaking it.

Code:

Option Explicit
Sub MoveData()
    Dim arToCols()
    Dim arFromCols()
    Dim i As Long, j As Long, y As Long, LastRow As Long, lSkip As Long, lRowCount As Long
    Dim WSTo As Worksheet
    Dim WSFrom As Worksheet
    Dim strFilter As String
    Dim rng As Range
    Dim c As Variant
    
    ' Set the worksheet objects
    Set WSFrom = ActiveWorkbook.Sheets("3")
    Set WSTo = ActiveWorkbook.ActiveSheet
    
    ' Set our filter, so we can run the same code on either sheet
    Select Case ActiveSheet.Name
        Case "1"
            strFilter = "Asset"
        Case "2"
            strFilter = "Stock"
    End Select
    
    ' Load up the arToCols() array with the column headers we need
    With WSTo
        For i = 1 To 12 Step 1
            ReDim Preserve arToCols(1 To 2, 1 To i)
            arToCols(1, i) = i
            arToCols(2, i) = .Cells(8, i).Value
        Next i
    End With
    
    ' Load up the arFromCols() array with the matching column headings, and also their
    ' column number on sheet 3
    With WSFrom
        ' Set the last row in sheet "3".  We will need this a couple of times
        LastRow = .Cells(65000, 1).End(xlUp).Row
        y = 1
        For i = 1 To 100 Step 1
            If Len("" & .Cells(1, i)) > 0 Then
                For j = 1 To 12 Step 1
                    If .Cells(1, i).Value = arToCols(2, j) Then
                        ReDim Preserve arFromCols(1 To 2, 1 To i)
                        arFromCols(1, y) = i
                        arFromCols(2, y) = .Cells(1, i).Value
                        y = y + 1
                    End If
                Next j
            Else
                Exit For
            End If
        Next i
    End With
    
    ' Determine how many rows of data we have for the current filter type
    ' We will use this number to determine if we need to insert rows on
    ' the active sheet
    With WSFrom
        Set rng = .Range(.Cells(2, 62), .Cells(LastRow, 62))
        lRowCount = 0
        For Each c In rng
            If c.Value = strFilter Then
                lRowCount = lRowCount + 1
            End If
        Next c
    End With
    
    ' If lRowCount > 8, we know we need to insert some rows.
    With WSTo
        If lRowCount > 1 Then
            For i = 1 To lRowCount - 8
                .Rows("16:16").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Next i
        End If
    End With
    
    ' Now, populate the data.  Basically here we are traversing the data on sheet "3" first,
    With WSTo
        lSkip = 0
        For i = 2 To LastRow Step 1
            ' This step looks for the filter in column 62
            If WSFrom.Cells(i, 62) = strFilter Then
                ' If we found the filter, then traverse both arrays to find a match
                ' on the column headings
                For y = 1 To 12 Step 1
                    For j = 1 To 12 Step 1
                        ' Once we match the column headings, populate the correct column on the
                        ' active sheet with the data from sheet "3".  Remember, we know which
                        ' column contains the data we need for each column, and it is stored
                        ' in arFromCols()
                        If .Cells(8, y).Value = arFromCols(2, j) Then
                            .Cells(7 + i - lSkip, y).Value = WSFrom.Cells(i, arFromCols(1, j))
                        End If
                    Next j
                Next y
            Else: lSkip = lSkip + 1
            End If
        Next i
    End With
   
End Sub

Greg

Copy rows to 2 sheets using criteria

moroformat

New member

Attachments

gsnidow

New member

gsnidow

New member