Copy destination problem

[Casey]

Hi,
I have a routine that reads the selections made in a Listbox and
transfers the ranges on wks1 associated with those selections to wks2.
The problem I'm having is when there are multiple selections, the first
range will copy in the correct place, but then the subsequent ranges one
by one overwrite the first range. I need them to start pasting at Row 20
Column D and if the first range is 30 rows the next range would skip a
row and paste at Row 51 Column D. Here's my code including the code for
the listbox UserForm.

Option Explicit
Sub UserForm_Initialize()
Dim Cell As Range

ListBox1.Clear
For Each Cell In Range("ScopeTitles")
ListBox1.AddItem Cell.Value
Next
End Sub
Private Sub cmdCancel_Click()
SelectScopesForm.Hide
End Sub

Private Sub cmdInsertScopes_Click()
Dim SelCount, i As Integer
Dim ScopePicks() As Integer
Dim RCount, r, c As Long
Dim wks1 As Worksheet
Dim wks2 As Worksheet

Set wks1 = Worksheets("Scopes")
Set wks2 = Worksheets("Proposal")
' Hide the userform
SelectScopesForm.Hide
' Get count on rows
RCount = wks1.UsedRange.Rows.Count
SelCount = 0
For i = 0 To SelectScopesForm.ListBox1.ListCount - 1
If SelectScopesForm.ListBox1.Selected(i) Then
SelCount = SelCount + 1
If i = 0 Then
ReDim ScopePicks(i + 1)
Else
ReDim Preserve ScopePicks(SelCount)
End If
ScopePicks(SelCount - 1) = i + 1
End If
Next i
If SelCount > 0 Then
' Loop through array and copy data from scopes selected
' in ListBox from Scopes worksheet to Proposal worksheet
For c = 0 To SelCount - 1
For r = 1 To RCount
' Here is the problem
wks2.Cells(r + 19, 4) = wks1.Cells(r, ScopePicks(c))
Next r
Next c
Else
MsgBox ("You didn't select any scopes.")
Exit Sub
End If
End Sub

 

[Casey]

Hi again,
I could really use some help. Once again I have cobbled together some
code from various places and it works................almost. Just a
little help please.

 

[Tom Ogilvy]

Option Explicit
Sub UserForm_Initialize()
Dim Cell As Range

ListBox1.Clear
For Each Cell In Range("ScopeTitles")
ListBox1.AddItem Cell.Value
Next
End Sub
Private Sub cmdCancel_Click()
SelectScopesForm.Hide
End Sub

Private Sub cmdInsertScopes_Click()
Dim SelCount, i As Long
Dim ScopePicks() As Integer
Dim RCount as Long, r as Long, c As Long
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim rw as Long

Set wks1 = Worksheets("Scopes")
Set wks2 = Worksheets("Proposal")
' Hide the userform
SelectScopesForm.Hide
' Get count on rows
RCount = wks1.UsedRange.Rows.Count
SelCount = 0
For i = 0 To SelectScopesForm.ListBox1.ListCount - 1
If SelectScopesForm.ListBox1.Selected(i) Then
SelCount = SelCount + 1
If i = 0 Then
ReDim ScopePicks(i + 1)
Else
ReDim Preserve ScopePicks(SelCount)
End If
ScopePicks(SelCount - 1) = i + 1
End If
Next i
If SelCount > 0 Then
' Loop through array and copy data from scopes selected
' in ListBox from Scopes worksheet to Proposal worksheet
rw = 1
For c = 0 To SelCount - 1
For r = 1 To RCount
' Here is the problem
wks2.Cells(rw + 19, 4) = wks1.Cells(r, ScopePicks(c))
rw = rw + 1
Next r
rw = rw + 1
Next c
Else
MsgBox ("You didn't select any scopes.")
Exit Sub
End If
End Sub

 

[Casey]

Tom,
Exactly what I needed. The time on the answer (at least in my tim
zone) was 10:40 pm, do you crank this great code out during commercia
breaks watching Letterman? Thank you very much for the help

 

[Tom Ogilvy]

I just made a modification or two to your code - probably during the
Olympics <g>