Created this to pull out some sample data from multiple areas of a workbook and paste them into a single area. Note use of PRESERVE to retain current values when redimensioning an array. The first REDIM does not include PRESERVE. The lifetime of the array arrCopyto is for as long as the workbook is open.Option Explicit Dim arrCopyto() Sub CopyToArray() Dim I As Long, j As Long, n As Long, cell As Range n = 0 'picks up values from multiple areas ReDim arrCopyto(0 To 1) 'no Preserve so starts fresh For I = 1 To Selection.Areas.Count On Error Resume Next 'in case nothing in selection For Each cell In Intersect(Selection.Areas(I), _ Cells.SpecialCells(xlConstants, xlTextValues)) n = n + 1 '-- Note use of Preserve -- ReDim Preserve arrCopyto(0 To n) arrCopyto(n) = cell.Value Next On Error GoTo 0 Next arrCopyto(0) = n End SubTo "paste" the array back to your worksheet, you can choose one of the following macros.
- PasteFromArray: will use the width of the selection and continue downward even though it goes beyond the selection area.
- PasteFromArrary_Limited: will not paste beyond the selection area.
Sub PasteFromArray() Dim I As Long '-- Not limited to selection, will continue down using width '-- of selection, which is what I really wanted For I = 1 To UBound(arrCopyto) Selection.Item(I) = arrCopyto(I) Next I done: Exit Sub End Sub Sub PasteFromArray_Limited() Dim I As Long '-- Limited to Selection For I = 1 To Application.Min(UBound(arrCopyto), Selection.Count) Selection.Item(I) = arrCopyto(I) Next I done: Exit Sub End Sub
Please send your comments concerning this web page to: David McRitchie send email comments
Copyright © 1997 - 2004, F. David McRitchie, All Rights Reserved