Using a macro to copy and paste lists of data from one sheet to another

**johnnieboi89** · 06-28-2011, 02:24 PM

I am a new member and This is my first post WHO-HOO!!! had to get that out of the way. Now back to business I am fairly new to excel. I am trying to develop a macro that will grab data from one sheet and paste it to another sheet by clicking the entry in a combo box. I was partially successful with actualy getting the data from one sheet to another by developing a macro for each field and linking the field name to a field in the combo box. However, I want the macro to neatly place the data side by side.

Im not really Familiar with loops and If then else statements. But here is my thought process.
My thought process is
1)have a cell to put the first data in
2)check to see if any data is in the first row
3)check the next 9 rows to see if any data is in it
3a)If not then Paste the copied contents
3b) if it is then go to the first row of the next column and repeat step 3

Here is the code for the entries
Every time i try and run it i get a compile error
I think its because of my loops but im not sure

Sheets("Sheet1").Select
        Range("b2:b12").Select
    
    ActiveSheet.Range("b2:b12").Copy
Sheets("Sheet2").Select
'My thoughht Process #1
ActiveSheet.Range("a1").Select
            
    ActiveCell.Offset(0, 1).Select
'My thought process #2
   Do While IsEmpty(ActiveCell.Offset(0, 1)) = False
   ActiveCell.Offset(0, 1).Select
   Loop Until IsEmpty(ActiveCell)

   Do
'My thought Process #3
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
'My thought Process 3b
    ActiveCell.Offset(-1, 1).Select
     End If
     Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
'My thought Process 3b
    ActiveCell.Offset(-2, 1).Select
     End If
      Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
'My thought Process 3b
    ActiveCell.Offset(-3, 1).Select
     End If
      Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
'My thought Process 3b
    ActiveCell.Offset(-4, 1).Select
     End If
      Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
'My thought Process 3b
    ActiveCell.Offset(-5, 1).Select
     End If
      Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
'My thought Process 3b
    ActiveCell.Offset(-6, 1).Select
     End If
      Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
'My thought Process 3b
    ActiveCell.Offset(-7, 1).Select
     End If
      Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(1, 0).Select
   ElseIf IsEmpty(ActiveCell) = False Then
  'My thought Process 3b
    ActiveCell.Offset(-8, 1).Select
     End If
      Loop
Do While IsEmpty(ActiveCell) = False
 If IsEmpty(ActiveCell) Then
  ActiveCell.Offset(-8, 0).Select
 'My thoguht Process #3a
   ActiveSheet.Paste Destination:=ActiveCell
    ElseIf IsEmpty(ActiveCell) = False Then
  'My thought Process 3b
     ActiveCell.Offset(-9, 1).Select
      End If
       Loop
           
End Sub

I uploaded the document because I know I probly did not do a good job explaining it. I labeled every thing in the comments as well

I need help...... when ever i get an error code it makes me sad
and I dont like to be sad. Thanks in advance for any help.

Johnnieboi

**tigeravatar** · 06-28-2011, 02:51 PM

johnnieboi89,

Welcome to the forum. Give this a try instead:

Sub DropDown2_Change()
    
    Const FirstCell As String = "B1"
    
    Dim rngDest As Range: Set rngDest = ActiveSheet.Range(FirstCell)
    Dim ddn_Code As DropDown
    Dim rngCodes As Range
    Dim ChosenCode As String
    Dim rngFound As Range
    
    Set ddn_Code = ActiveSheet.DropDowns(Application.Caller)
    Set rngCodes = Sheets("Sheet1").Range("B1", Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft))
    ChosenCode = ddn_Code.List(ddn_Code.Value)
    
    Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    If rngFound Is Nothing Then Exit Sub
    Set rngFound = rngFound.Offset(1, 0).Resize(rngFound.CurrentRegion.Rows.Count - 1, 1)
    
    If rngDest.Value = vbNullString Then
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    Else
        Set rngDest = ActiveSheet.Cells(rngDest.Row, Columns.Count).End(xlToLeft).Offset(0, 1)
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    End If
    
End Sub

Hope that helps,
~tigeravatar

**realniceguy5000** · 06-28-2011, 02:53 PM

Maybe?

Sub DropDown2_Change()
With ActiveSheet.DropDowns(Application.Caller)
   Application.Run .List(.ListIndex)
End With
End Sub

Sub mj()
Dim lrow As Long
lrow = Sheets(1).Range("B65536").End(xlUp).Row
With Sheets(1)
.Range("B2:B" & lrow).Copy Destination:=Sheets(2).Range("A1").Offset(, 1)
End With
   
End Sub
Sub kb()
Dim lrow As Long
lrow = Sheets(1).Range("C65536").End(xlUp).Row
With Sheets(1)
.Range("C2:C" & lrow).Copy Destination:=Sheets(2).Range("A1").Offset(, 1)
End With
End Sub
Sub dw()
Dim lrow As Long
lrow = Sheets(1).Range("E65536").End(xlUp).Row
With Sheets(1)
.Range("E2:E" & lrow).Copy Destination:=Sheets(2).Range("A1").Offset(, 1)
End With
End Sub
Sub lbj()
Dim lrow As Long
lrow = Sheets(1).Range("D65536").End(xlUp).Row
With Sheets(1)
.Range("D2:D" & lrow).Copy Destination:=Sheets(2).Range("A1").Offset(, 1)
End With
End Sub

**johnnieboi89** · 06-28-2011, 03:37 PM

Wow replies come back fast on here and it worked to perfection. Thanks so much
However, I do have another question in my document I only had 4 different field names which is a fraction of the whole document how do you suggest I go about handling over a ton of fields. Like somewhere around 1000 or so

**tigeravatar** · 06-28-2011, 03:39 PM

johnnieboi89,

The macro I provided will already automatically adjust for more field names and rows per field. No changes necessary.

~tigeravatar

**johnnieboi89** · 06-28-2011, 03:53 PM

here is tha actual document. It may be a little different because the Source data comes from multiple pages. Thanks in advance
johnnieboi

**tigeravatar** · 06-28-2011, 04:38 PM

johnnieboi89,

Updated code:

Sub DropDown1_Change()
    
    Const FirstCell As String = "B1"
    
    Dim rngDest As Range: Set rngDest = ActiveSheet.Range(FirstCell)
    Dim ddn_Code As DropDown
    Dim rngCodes As Range
    Dim ChosenCode As String
    Dim rngFound As Range
    
    Dim ws1 As Worksheet: Set ws1 = Sheets("Quarterly AM Best")
    Dim ws2 As Worksheet: Set ws2 = Sheets("Annual AM Best")
    
    Set ddn_Code = ActiveSheet.DropDowns(Application.Caller)
    ChosenCode = ddn_Code.List(ddn_Code.Value)
    
    Set rngCodes = ws1.Range("C1", ws1.Cells(1, Columns.Count).End(xlToLeft))
    Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    If rngFound Is Nothing Then
        Set rngCodes = ws2.Range("C1", ws2.Cells(1, Columns.Count).End(xlToLeft))
        Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    End If
    Set rngFound = rngFound.Offset(1, 0).Resize(rngFound.CurrentRegion.Rows.Count - 1, 1).SpecialCells(xlCellTypeConstants)
    
    If rngDest.Value = vbNullString Then
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    Else
        Set rngDest = ActiveSheet.Cells(rngDest.Row, Columns.Count).End(xlToLeft).Offset(0, 1)
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    End If
    
End Sub

Hope that helps,
~tigeravatar

**johnnieboi89** · 06-28-2011, 04:39 PM

I tried your code and it didnt work for this document. I also changed the name of the sheet to the one specific for this document and i stI got a subscript out of Range error
here is the code as i had to modify it

  Sub DropDown2_Change()
    
    Const FirstCell As String = "B1"
    
    Dim rngDest As Range: Set rngDest = ActiveSheet.Range(FirstCell)
    Dim ddn_Code As DropDown
    Dim rngCodes As Range
    Dim ChosenCode As String
    Dim rngFound As Range
    
    Set ddn_Code = ActiveSheet.DropDowns(Application.Caller)
    Set rngCodes = Sheets("Total Annual").Range("B1", Sheets("Total Annual").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("LH Annual").Range("B1", Sheets("LH Annual").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("PC Annual").Range("B1", Sheets("PC Annual").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("Reinsurance").Range("B1", Sheets("Reinsurance").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("Quarterly AM Best").Range("B1", Sheets("Quarterly AM Best").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("Annual AM Best").Range("B1", Sheets("Annual AM Best").Cells(1, Columns.Count).End(xlToLeft))
    ChosenCode = ddn_Code.List(ddn_Code.Value)
    
    Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    If rngFound Is Nothing Then Exit Sub
    Set rngFound = rngFound.Offset(1, 0).Resize(rngFound.CurrentRegion.Rows.Count - 1, 1)
    
    If rngDest.Value = vbNullString Then
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    Else
        Set rngDest = ActiveSheet.Cells(rngDest.Row, Columns.Count).End(xlToLeft).Offset(0, 1)
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    End If
    
End Sub

Thanks again
Johnnieboi