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
Reply With Quote
Bookmarks