macro to copy a cell from one sheet and paste it 3 time in another sheet

[avbraga]

Hi all,

I have this situation:
in sheet1 I have some string data with the cell content being something like the following:

a1 = database mgmt
a2 = programming languages
a3 = IT acquisition

I want to be able to transfer the data on sheet1 to sheet2 in the following way:

a1 = database mgmt
a2 = database mgmt
a3 = database mgmt
a4 = programming languages
a5 = programming languages
a6 = programming languages
a7 = IT acquisition
a8 = IT acquisition
a9 = IT acquisition
... etc

I've done it the "easy" way, using copy cell and repeat it 3 times for all cells on sheet 1 going to sheet2, but would like to see an alternative way to do this more effectively using VBA.

Since I'm a VBA newbie and I'm not being successful writing a macro to do this, I'm here to ask for your help and knowledge. Any help would be greatly appreciated. Please let me know. Thanks.

Alex

 

[Saagar]

Try this:

You can change the number "3" to the number of rows in sheet1.

Sub newmacro()

for j = 1 to 3
copyvalue = worksheets("sheet1").cells(j,1)

worksheets("sheet2").cells(3*j-2,1) = copyvalue
worksheets("sheet2").cells(3*j-1,1) = copyvalue
worksheets("sheet2").cells(3*j,1) = copyvalue

next

end sub

 

[texasalynn]

another way

Sub CopyData()
Dim LR As Long
LR = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
CData = ActiveCell.Value
Worksheets("Sheet2").Activate
Range(Cells(LR, 1), Cells(LR + 2, 1)) = CData

End Sub

 

[avbraga]

Saagar, your code works great. Thanks a lot!

texasalynn, I'll check yours too, since I'm in the process of getting familiar with the VBA syntax, and seeing things 2 ways will definitely help me.

Thanks a lot!

Alex

 

[GTO]

Another example, this uses what cells you have selected initially.

Option Explicit
    
Sub exa1()
Dim rngStart        As Range
Dim aryVals()       As Variant
Dim aryOutput()     As Variant
Dim i               As Long
Dim n               As Long
Dim y               As Long
    
    If TypeName(ActiveSheet) = "Worksheet" Then
        If Selection.Columns.Count > 1 Or Selection.Cells.Count = 1 Then
            MsgBox "I can only do this with one column and there must be more than one cell selected.", 0, vbNullString
            Exit Sub
        Else
            Set rngStart = Selection.Cells(1)
            aryVals = Selection.Value
            ReDim aryOutput(1 To 3 * UBound(aryVals, 1), 1 To 1)
            
            For i = 1 To UBound(aryVals, 1)
                For n = 1 To 3
                    y = y + 1
                    aryOutput(y, 1) = aryVals(i, 1)
                Next
            Next
            
            rngStart.Select
            Set rngStart = Nothing
            On Error Resume Next
            Set rngStart = Application.InputBox("Where would you like to plunk the data?  Select a cell, then press <OK>", "Stutter vals...", , , , , , 8)
            On Error GoTo 0
            
            If Not rngStart Is Nothing Then
                rngStart.Resize(UBound(aryOutput, 1)).Value = aryOutput
                Application.Goto rngStart
            Else
                MsgBox "You cancelled or goofed something, start over.", vbOKOnly, vbNullString
            End If
        End If
    End If
End Sub

 

[avbraga]

Sweet GTO, thanks. Will check your logic out.

Thanks for the help guys!