Insert "N" columns between Column B and C. Copy Range. Transpose. Paste Values

[jwb1012]

Hello everyone... I am attempting to come up with a code to do the following . Any thoughts/guidance would be much appreciated!

On Source_Sh ("SOURCE"):

• In column E (from row 9+)...I have a list that the user will input values - which will become column headings
• In cell $I$23 I have a count of how many values are inserted into this range ("N")

On Dest_Sh ("DESTINATION"):

• I need to insert "N" columns between column B and column C
• Then I need to copy the list from column E on Source_Sh, transpose and paste values into row 1 of Dest_Sh...in the columns that were just added between column B and (former) column C

EXAMPLE:

Source_Sh
"New Heading 1" ..... E9
"New Heading 2" ..... E10

As a result.... $I$23 = 2


Dest_Sh

(before code)

Column A

Column B

Column C

Column D

<tbody>
</tbody>

(after code)

Column A

<new 1="" Heading="">Column B</new>

<new 2="" Heading="">NEW HEADING 1</new>

NEW HEADING 2

Column C

Column D

<tbody>
</tbody>

 

[JoeMo]

Not clear to me what your actual sheet names are. Change "SOURCE" & "DESTINATION" to your sheet names.

Sub InsertN()
Dim N As Long
N = Sheets("SOURCE").Range("I23")
With Sheets("DESTINATION")
       .Columns("C").Resize(, N).Insert
       Sheets("SOURCE").Range("E9:E" & 9 + N - 1).Copy
       .Range("C1").PasteSpecial Paste:=xlValues, Transpose:=True
       Application.CutCopyMode = False
End With
End Sub

 

[jwb1012]

Hi Joe - thank you very much. It works!

This may be a bit difficult, but I figured I would go ahead and ask. Now that I have these column headings in place... I was wondering if it's possible to match these column headings (which will be different under various scenarios) to the column headings in row 13 of the sheet "Staffing Plan" ... if there is a match, then copy the data in that column (row 14 to the last row) on the Staffing Plan worksheet to the Res Hrs Cost-PP worksheet (what I referred to as "Destination").

Here is the code you provided with my worksheet names:

Sub InsertN()
Dim N As Long
N = Sheets("Pricing").Range("I23")
With Sheets("Res Hrs Cost-PP")
       .Columns("C").Resize(, N).Insert
       Sheets("Pricing").Range("E9:E" & 9 + N - 1).Copy
       .Range("C1").PasteSpecial Paste:=xlValues, Transpose:=True
       Application.CutCopyMode = False
End With
End Sub

 

[JoeMo]

Hi Joe - thank you very much. It works!

This may be a bit difficult, but I figured I would go ahead and ask. Now that I have these column headings in place... I was wondering if it's possible to match these column headings (which will be different under various scenarios) to the column headings in row 13 of the sheet "Staffing Plan" ... if there is a match, then copy the data in that column (row 14 to the last row) on the Staffing Plan worksheet to the Res Hrs Cost-PP worksheet (what I referred to as "Destination").

You are welcome - thanks for the reply.

For your new request I assume you want to first generate the headers in sheet "Res Hrs Cost-PP" first, then gather the data from "Staffing Plan" and paste it under applicable headers in "Res Hrs Cost-PP". This code will do that. Note that I have assigned two constants to reflect the starting points (row numbers) in sheets "Pricing" and "Staffing Plan" in case those should change over time.

Sub InsertNandGetData()
Const startRowPrice As Long = 9   'set the row number where header info begins in Pricing sheet here
Const startRowStaffing As Long = 13   'set the header row number in sheet "staffing plan" here
Dim N As Long, Fnd As Range, c As Range, lR As Long
N = Sheets("Pricing").Range("I23")
Application.ScreenUpdating = False
With Sheets("Res Hrs Cost-PP")
        .Columns("C").Resize(, N).Insert
        Sheets("Pricing").Range("E9:E" & startRowPrice + N - 1).Copy
        .Range("C1").PasteSpecial Paste:=xlValues, Transpose:=True
        Application.CutCopyMode = False
        For Each c In .Range("C1").Resize(1, N)
            On Error Resume Next
            Set Fnd = Sheets("Staffing Plan").Rows(startRowStaffing).Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
            On Error GoTo 0
            If Fnd Is Nothing Then GoTo Nx
            lR = Sheets("Staffing Plan").Cells(Rows.Count, Fnd.Column).End(xlUp).Row
            Sheets("Staffing Plan").Range(Fnd.Offset(1, 0), Fnd.Offset(lR - startRowStaffing, 0)).Copy
            c.Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
Nx:
        Next c
End With
Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

Not clear to me what your actual sheet names are. Change "SOURCE" & "DESTINATION" to your sheet names.

Sub InsertN()
Dim N As Long
N = Sheets("SOURCE").Range("I23")
With Sheets("DESTINATION")
       .Columns("C").Resize(, N).Insert
       Sheets("SOURCE").Range("E9:E" & 9 + N - 1).Copy
       .Range("C1").PasteSpecial Paste:=xlValues, Transpose:=True
       Application.CutCopyMode = False
End With
End Sub

Provided the list in cell E9 on down numbers less than about 64000 cells, then the three lines of code I highlighted above can be replaced with this single line of code...

.Range("C1").Resize(, N) = Application.Transpose(Sheets("SOURCE").Range("E9").Resize(N))

 

[jwb1012]

Incredible! Thank you both so very much! I've learned so much today!

Do you have a suggestion on the best way to auto-fit column widths for the new columns that were added?. Right now, they are way too wide so I was hoping to auto-fit to the required width.

Thanks again!!

 

[JoeMo]

Incredible! Thank you both so very much! I've learned so much today!

Do you have a suggestion on the best way to auto-fit column widths for the new columns that were added?. Right now, they are way too wide so I was hoping to auto-fit to the required width.

Thanks again!!

You are welcome.

To autofit, place this line just before the End With line near the end of the sub in post #4:

.Columns("C").Resize(, N).Autofit

 

[jwb1012]

Thanks Joe. I work up this morning and the overall code to copy/paste the data when the column header appeared not to work..

What I actually found out is that it couldn't find the columns since I had hidden these columns on the Staffing Plan worksheet. Is it possible to adjust so I can have these columns hidden? Or unhide columns L:U on Staffing Plan, run the wonderful code, then re-hide columns L:U on Staffing Plan?

 

[JoeMo]

Thanks Joe. I work up this morning and the overall code to copy/paste the data when the column header appeared not to work..

What I actually found out is that it couldn't find the columns since I had hidden these columns on the Staffing Plan worksheet. Is it possible to adjust so I can have these columns hidden? Or unhide columns L:U on Staffing Plan, run the wonderful code, then re-hide columns L:U on Staffing Plan?

Try this version.

Sub InsertNandGetData()
Const startRowPrice As Long = 9   'set the row number where header info begins in Pricing sheet here
Const startRowStaffing As Long = 13   'set the header row number in sheet "staffing plan" here
Dim N As Long, Fnd As Range, c As Range, lR As Long
N = Sheets("Pricing").Range("I23")
Application.ScreenUpdating = False
Sheets("Staffing Plan").Columns("L:U").Hidden = False
With Sheets("Res Hrs Cost-PP")
        .Columns("C").Resize(, N).Insert
        Sheets("Pricing").Range("E9:E" & startRowPrice + N - 1).Copy
        .Range("C1").PasteSpecial Paste:=xlValues, Transpose:=True
        Application.CutCopyMode = False
        For Each c In .Range("C1").Resize(1, N)
            On Error Resume Next
            Set Fnd = Sheets("Staffing Plan").Rows(startRowStaffing).Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
            On Error GoTo 0
            If Fnd Is Nothing Then GoTo Nx
            lR = Sheets("Staffing Plan").Cells(Rows.Count, Fnd.Column).End(xlUp).Row
            Sheets("Staffing Plan").Range(Fnd.Offset(1, 0), Fnd.Offset(lR - startRowStaffing, 0)).Copy
            c.Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
Nx:
        Next c
        .Columns("C").Resize(, N).AutoFit
End With
Sheets("Staffing Plan").Columns("L:U").Hidden = True
Application.ScreenUpdating = True
End Sub