Greetings,
This isn't much, but maybe a start?
Option Explicit
Public Sub example01()
Const DESTNAME = "Destination"
Const SOURCENAME = "Source"
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim rngFound As Range
Dim rngData As Range
Dim lRowCount As Long
Dim n As Long
'// Ensure both sheets exist. //
If Not (SheetExists(DESTNAME) And SheetExists(SOURCENAME)) Then
MsgBox "error missing sheet(s)...", vbCritical, vbNullString
Exit Sub
End If
Set wksDest = ThisWorkbook.Worksheets(DESTNAME)
Set wksSource = ThisWorkbook.Worksheets(SOURCENAME)
With wksSource
'// Find any type data in the last row w/data in columns of insterest. If this //
'// fails, bail. //
Set rngFound = RangeFound(.Range(.Range("A4"), .Cells(.Rows.Count, "G")))
If rngFound Is Nothing Then
MsgBox "No data...", vbInformation, vbNullString
Exit Sub
End If
'// Else, Set a reference to the range of interest (including the header row for //
'// the moment). //
Set rngData = .Range(.Range("A3"), .Cells(rngFound.Row, "G"))
End With
With rngData
.Parent.AutoFilterMode = False
.AutoFilter Field:=7, Criteria1:="02"
'// See how many visible rows there are, so we know how many rows to insert. Note //
'// that we ditched the header row since we just want the data. //
For n = 1 To .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Areas.Count
lRowCount = _
lRowCount + _
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Areas(n).Rows.Count
Next
'// You'll need something better (dynamic) than this to build the address in some //
'// manner, but I'm not quite following as well as I should be. //
wksDest.Range("5:" & CStr(5 + (lRowCount - 1))).Insert xlDown
'// Copy the visible cells to the created rows. //
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy wksDest.Range("A5")
.Parent.AutoFilterMode = False
End With
End Sub
Public Function SheetExists(ByVal ShName As String, Optional ByVal WB As Workbook) As Boolean
If WB Is Nothing Then Set WB = ThisWorkbook
On Error Resume Next
SheetExists = (WB.Worksheets(ShName).Name = ShName)
End Function
Public Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange.Cells(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function
If the results look anything like what you are going after, maybe we could used the named range cells on the destination sheet to figure out where we insert each time?
Mark
Reply With Quote
Originally Posted by GTO
