Help with creating a VBA

[paritoshmehta]

Hi,

I have the following data:

ID# | Name | Supervisor
123 | Name1| SUP1
456 | Name2| SUP2
789 | Name3| SUP3
124 | Name4| SUP4
..................................
..................................



I want to create a Macro which would copy this data and paste 4 record
each to a different location in the same sheet, i.e. after running th
macro the data should look like:

ID# | Name | Supervisor
123 | Name1| SUP1
123 | Name1| SUP1
123 | Name1| SUP1
123 | Name1| SUP1
456 | Name2| SUP2
456 | Name2| SUP2
456 | Name2| SUP2
456 | Name2| SUP2
789 | Name3| SUP3
789 | Name3| SUP3
789 | Name3| SUP3
789 | Name3| SUP3
................


What I want is a macro which would copy the non empty cells and past
them accordingly without telling it what all to paste, i.e. lets say i
i added "name 5" in the list and also made some changes in "name2" i
would copy all the data into the desired result!!!(without changing th
other cells, i.e. just paste it to column a,b,c and thats it!)
I also wanted to have a password to run the macro, i.e. only someon
with the rights can run the macro!!!

Could someone help me with this?

Thanks
Paritosh Meht

 

[Greg Wilson]

I'm not sure I understood your request. This is my
interpretation.

As I read your post, you may have empty cells in the
data. I therefore structured the code to exclude empty
cells. Empty cells in the original data are deliberately
excluded in the copied data.

The code assumes that the headings ID#, Name and
Supervisor are in Cells A1 to C1 respectively with the
data starting immediately below. Four copies of each data
set are created and copied to Column E. Change the range
references to suit. Test the code with empty cells in the
original data. Note that you will have to correct for
wordwrap.

Const Pwd As String = "monkey"

Sub TestZZZ()
Dim txt As String, i As Integer, ii As Integer
Dim Rng As Range, C As Range, Rw As Integer

'<<<<< Password entry >>>>>
i = 0
Do Until txt = Pwd
txt = InputBox("Enter password to
continue . . . ", "Password Entry")
If txt = "" Then
Exit Sub
ElseIf txt <> Pwd Then
i = i + 1
If i = 3 Then
MsgBox "Access denied !!! " & _
"Contact your administrator for access to this
feature. ", _
vbInformation, "Access denied"
Exit Sub
End If
MsgBox "Password failed. Please try again. ",
vbExclamation, "Password entry"
End If
Loop

'<<<<< Transfer data >>>>>
i = 0
Rw = Range("A65536").End(xlUp).Row
Set Rng = Range("A2:A" & Rw).SpecialCells
(xlCellTypeConstants)
For Each C In Rng
For ii = 1 To 4
Range(Cells(i + ii, 5), Cells(i + ii, 7)) = Range
(C, C.Offset(, 2)).Value
Next
i = i + 4
Next

End Sub

Regards,
Greg

 

[paritoshmehta]

Hi Greg,

Thanks a ton for the reply!!! I tried the code and it is working preet
fine for me,

I just had one question, can we have a system whete the names are i
sheet2 and the pasting happens in sheet 1 (in the cells a to c)?


Thanks a million for your help!!!!

Paritos

 

[paritoshmehta]

Hi Greg,

Just one more help on the same issue, this code works fine for th
first 4 entries, what changes do i make for it to copy the entire no
blank entries in a column and paste them!!!

Thanks again!!

 

[Greg Wilson]

Paritosh,

I tested the code and it works for all non-empty cells in
Column A -- not just the first four (???). A specific
example follows. The headings are in row 1 with Id Num,
Name and Supervisor in cells A1 to C1 respectively. The
data immediately follows as shown below. Gaps are
deliberate indicating blank rows. Following the data list
shown immediately below are the results of the macro run
on these data. This is my interpretation of what you
wanted. Is this not what you get from running the
macro?

<<<< Data >>>>>

Id Num Name Supervisor
ID1 Name1 Sup1

ID2 Name2 Sup2

ID3 Name3 Sup3
ID4 Name4 Sup4
ID5 Name5 Sup5

ID6 Name6 Sup6
ID7 Name7 Sup7


ID8 Name8 Sup8

<<<<< Macro result in Column E >>>>>

ID1 Name1 Sup1
ID1 Name1 Sup1
ID1 Name1 Sup1
ID1 Name1 Sup1
ID2 Name2 Sup2
ID2 Name2 Sup2
ID2 Name2 Sup2
ID2 Name2 Sup2
ID3 Name3 Sup3
ID3 Name3 Sup3
ID3 Name3 Sup3
ID3 Name3 Sup3
ID4 Name4 Sup4
ID4 Name4 Sup4
ID4 Name4 Sup4
ID4 Name4 Sup4
ID5 Name5 Sup5
ID5 Name5 Sup5
ID5 Name5 Sup5
ID5 Name5 Sup5
ID6 Name6 Sup6
ID6 Name6 Sup6
ID6 Name6 Sup6
ID6 Name6 Sup6
ID7 Name7 Sup7
ID7 Name7 Sup7
ID7 Name7 Sup7
ID7 Name7 Sup7
ID8 Name8 Sup8
ID8 Name8 Sup8
ID8 Name8 Sup8
ID8 Name8 Sup8

As for your request to change the sheet to a different
sheet, the following code will copy the data from the
active sheet to Sheet("Sheet2") instead of to the active
sheet. Change sheet names and cell references to suit and
correct for wordwrap.

'<<<<< Transfer data >>>>>
i = 0
Rw = Range("A65536").End(xlUp).Row
Set Rng = Range("A2:A" & Rw).SpecialCells
(xlCellTypeConstants)
For Each C In Rng
For ii = 1 To 4
With Sheets("Sheet2")
.Range(.Cells(i + ii, 5), .Cells(i + ii, 7)) =
Range(C, C.Offset(, 2)).Value
End With
Next
i = i + 4
Next

End Sub

Regards,
Greg

 

[paritoshmehta]

Hi Greg


Thanks a million for your help, you really are amazing!!!!!!!

just one last thing, now i am using the code so that i enter data i
sheet 2(cells a, b and c) and the data gets copied to sheet 1 (agai
cells a, b and c; I have made some changes in the code); I just want t
leave one empty row in sheet 1 for the header and am not able to figur
how to go about it!! Please help


'<<<<< Transfer data >>>>>
i = 0
Sheets("Sheet2").Select
Rw = Range("A65536").End(xlUp).Row
Set Rng = Range("A2:A" & Rw).SpecialCells(xlCellTypeConstants)
For Each C In Rng
For ii = 1 To 4
With Sheets("Sheet1")
.Range(.Cells(i + ii, 1), .Cells(i + ii, 3)) = Range(C, C.Offset(
2)).Value
End With
Next
i = i + 4
Next
End Sub

Thanks again!!

 

[Greg Wilson]

Just change the first line i = 0 to i = 1.

Regards,
Gre

 

[paritoshmehta]

Hey Greg,

Let me tell you that you are the BEST!!!!!

Thanks a ton for your help, you have been of great help!!!

Cheers
Paritosh Mehta!

(e-mail address removed)