VBA to Copy Data and Paste On a Loop

[Jess709]

I am in the early stages of learning VBA and Macros and am in need of assistance.

I have a spreadsheet with 2 tabs of data. First tab named "acctinfo" has 2 columns of data. Column A is for the account numbers and column B is for job descriptions. Second tab named "jobdescriptions" just has one column of data, A. At the present time there are 214 rows, but depending on the data there may be more rows than that.

I need to copy a set of data from the 2nd tab, named "JobDescriptions" and paste it into the 1st tab named "AcctInfo" In the JobDescriptions tab I want the macro to copy the data starting with the first cell under the column heading (i.e B2), until it reaches a blank cell. After the data is copied I want it to be pasted into the 1st tab starting in cell B2. I then want it to continue pasting that same set of data until the last cell that has a value column A (example A2:A214).

The objective is to provide our programming department with a spreadsheet of job descriptions for 49 accounts and each account has to have a row for every job description. For example, if there are 213 job descriptions then the spreadsheet will have 213 rows for account # 64104408, 213 rows for account # 6414409 and so on.

Here is a sample of what the final output would look like, shortened.

Thank you so much for any help you can provide!!

Acct #	Job Description
64104408	ACAD AFF STAFF ADM__UNCLASSIFIED
64104408	ACADEMIC AFFAIRS OF__UNCLASSIFIED
64104408	ACCOUNT CLERK__UNCLASSIFIED
64104408	ACCOUNTANT__UNCLASSIFIED
64104408	ACCOUNTANT 1__CLASSIFIED
64104408	ACCOUNTANT 2__CLASSIFIED
64104408	ACCOUNTANT 3__CLASSIFIED

<tbody>
</tbody>

 

[offthelip]

Your requirements of not very clear however this code might do what you want, but it might show you how to do it

Sub copyd()
Dim outarr As Variant


With Worksheets("jobdescriptions")
 lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
 jobs = Range(.Cells(1, 1), .Cells(lastrow, 1))
End With
With Worksheets("acctinfo")
 lastrowa = .Cells(Rows.Count, "A").End(xlUp).Row
 accts = Range(.Cells(1, 1), .Cells(lastrow, 1))
ReDim outarr(1 To lastrow * lastrowa, 1 To 2)
indi = 1
For i = 2 To lastrowa
 For j = 2 To lastrow
  outarr(indi, 1) = accts(i, 1)
  outarr(indi, 2) = jobs(j, 1)
  indi = indi + 1
 Next j
Next i




 Range(.Cells(1, 1), .Cells(lastrow * lastrowa, 2)) = outarr
End With


End Sub

 

[Jess709]

That didn't work, I got an error on this line of code "outarr(indi, 1) = accts(i, 1)".

Maybe these requirements are a little clearer:
1. I need to copy a set of data from the "jobdescriptions" tab (ex. A2:A214), keeping in mind that the number of cells may vary. I want it to copy how ever many cells have data.

2. Then I want to paste that selected data into the tab named "acctinfo" into cell B2. So if the data set copied had 213 rows, it would've pasted into rows 2-214.

3. After that data is pasted I want it to paste the same data starting with B215. So it would paste that data from B215-B427. I need it to do this until there is no data in the corresponding row in column A. I want it to stop when column A is blank.

Let me know if you need more info.

 

[Jess709]

I have an update. I had a colleague help me work on some code and we have it working, but there is a problem. We need the code below to stop the loop of pasting once the cells in column A are blank. If anyone can help us modify the code to stop when the values in column A stop, it would get us to the finish line

Sub CopyJobDesc()
'
' CopyJobDesc Macro
'
Set r = Range("A" & Cells.Rows.Count).Select
Sheets("JobDescriptions").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("AcctInfo").Select
Range("B2").Select

Do

Range("B" & Cells.Rows.Count).End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Set r = Cells(r.Row + 1) 'Range("B" & Cells.Rows.Count)
If r.Value < 0 Then Exit Do

Loop
End Sub

 

[Fluff]

Is this what you need?

Sub copyData()

   Dim rng As Range
   Dim Cnt As Long
   
   With Sheets("JobDescriptions")
      Set rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
   End With
   With Sheets("acctinfo")
      For Cnt = .Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
         .Range("A" & Cnt + 1).Resize(rng.Count - 1).EntireRow.Insert
         .Range("A" & Cnt).Resize(rng.Count).FillDown
         .Range("B" & Cnt).Resize(rng.Count).Value = rng.Value
      Next Cnt
   End With
End Sub

 

[Jess709]

Is this what you need?

Sub copyData()

   Dim rng As Range
   Dim Cnt As Long
   
   With Sheets("JobDescriptions")
      Set rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
   End With
   With Sheets("acctinfo")
      For Cnt = .Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
         .Range("A" & Cnt + 1).Resize(rng.Count - 1).EntireRow.Insert
         .Range("A" & Cnt).Resize(rng.Count).FillDown
         .Range("B" & Cnt).Resize(rng.Count).Value = rng.Value
      Next Cnt
   End With
End Sub

Where in my code should I insert yours?

 

[Fluff]

It replaces all of your code.

 

[Jess709]

I tried that and there is no copy and paste in the code, so it doesn't get the job done.

 

[Fluff]

This line

.Range("B" & Cnt).Resize(rng.Count).Value = rng.Value

Inserts the values from col A of Job descriptions into col B of Acctinfo.

 

[Jess709]

I tried it again and it is actually adding the job descriptions starting with the last account number in column A of "acctinfo" and going down, which results in 600,000 rows instead of 12,000. I need it to start pasting in cell B2 of acctinfo and continue pasting the same set of data until there is no account number in column A.