Copy successive data in a column to successive sheets

ChaosPup

New Member
Joined
Sep 27, 2021
Messages
48
Office Version
  1. 365
Platform
  1. Windows
Hi everyone, I've written a macro to create a user defined number of new worksheets. What I'd like to do next is to have it copy successive entries in a column (I'm starting at F8) into the I3 cell in successive new sheets (i.e., contents of F8 to I3 in first new sheet, contents of F9 to I3 in second new sheet and so on). The number of entries in the column is variable but will always match the number of sheets, and can consist of numbers, letters and symbols. I've tried a few things, but all I can manage so far is getting it to put F8 in I3 of every sheet rather than working down the column. I've put my code below - any help greatly appreciated!!

Sub COPYFAT()

VBA Code:
Application.DisplayAlerts = False   'Turns OFF error reporting overwrites file without prompting
Application.ScreenUpdating = False
   
   'Varible declarations
   
    Dim UnitNum As Variant      'Number of units
    Dim SheetName As Variant    'Name of sheet
    Dim TagNum As Variant
    Dim I As Integer            'Counter
    Dim Start As Integer        'First SN
    Dim Increment As Integer    'SN+1
    Dim xNumber As Integer
    Dim xName As String
    Dim xActiveSheet As Worksheet
    
    Start = Sheets("Control").Range("B10")
    UnitNum = Sheets("Control").Range("B9").Value - 1         'Number of units pulled from CELL B23 on control sheet ***-1 because index starts at ZERO***
    Worksheets(Range("B8").Value).Activate                    'Name of Sheet to copy from CELL B8 on control sheet
    Set xActiveSheet = ActiveSheet
            
    For I = 0 To UnitNum                                      'Planning to add this number to cell reference for name starts at zero so initial reference is correct
        Increment = Start + I
        TagNum = Sheets("Control").Range("F8")
        xName = ActiveSheet.Name
        xActiveSheet.Copy After:=ActiveWorkbook.Sheets(xName)
        ActiveSheet.Name = Sheets("Control").Range("B12") & "-" & Increment
        ActiveSheet.Range("A1") = Sheets("Control").Range("B12") & " Factory Acceptance Test Report"
        ActiveSheet.Range("I4") = Sheets("Control").Range("B8") & "-" & Increment
        ActiveSheet.Range("I2") = Sheets("Control").Range("B12")
        ActiveSheet.Range("I5") = Sheets("Control").Range("B13")
        ActiveSheet.Range("I6") = Sheets("Control").Range("B14")
        ActiveSheet.Range("I7") = Sheets("Control").Range("B15")
        ActiveSheet.Range("J10") = Sheets("Control").Range("B17")
        ActiveSheet.Range("J12") = Sheets("Control").Range("B18")
        ActiveSheet.Range("N14") = Sheets("Control").Range("B19")
        ActiveSheet.Range("O32") = Sheets("Control").Range("B20")
        ActiveSheet.Range("D41") = Sheets("Control").Range("B21")
        ActiveSheet.Range("D43") = Sheets("Control").Range("B15")
        ActiveSheet.Range("I3") = TagNum
    Next
    xActiveSheet.Activate
    
    Sheets("CONTROL").Activate
    
Application.DisplayAlerts = True                              'Turns ON error reporting
Application.ScreenUpdating = True

End Sub
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Try
VBA Code:
TagNum = Sheets("Control").Range("F8").Offset(I)
 
Upvote 0
Solution
Try this:

VBA Code:
Sub COPYFAT_2()
  Dim i As Long, Start As Long, UnitNum As Long, Increment As Long
  Dim shC As Worksheet, shT As Worksheet, shN As Worksheet
  Dim xName As String

  Application.DisplayAlerts = False       'Turns OFF error reporting overwrites file without prompting
  Application.ScreenUpdating = False
  
  Set shC = Sheets("Control")
  Set shT = Sheets(shC.Range("B8").Value) 'Name of Sheet to copy from CELL B8 on control sheet
  Start = shC.Range("B10").Value          'start
  UnitNum = shC.Range("B9").Value         'Number of units pulled on control sheet
  xName = shT.Name
        
  For i = 1 To UnitNum                    'Planning to add this number to cell reference
    Increment = Start + i - 1
    shT.Copy After:=Sheets(xName)
    Set shN = ActiveSheet
    shN.Name = shC.Range("B12") & "-" & Increment
    xName = shN.Name
    shN.Range("A1") = shC.Range("B12") & " Factory Acceptance Test Report"
    shN.Range("I4") = shC.Range("B8") & "-" & Increment
    shN.Range("I2") = shC.Range("B12")
    shN.Range("I5") = shC.Range("B13")
    shN.Range("I6") = shC.Range("B14")
    shN.Range("I7") = shC.Range("B15")
    shN.Range("J10") = shC.Range("B17")
    shN.Range("J12") = shC.Range("B18")
    shN.Range("N14") = shC.Range("B19")
    shN.Range("O32") = shC.Range("B20")
    shN.Range("D41") = shC.Range("B21")
    shN.Range("D43") = shC.Range("B15")
    shN.Range("I3") = shC.Range("F" & 7 + i)
  Next
  shC.Activate
End Sub
 
Upvote 0
Glad we could help & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,335
Members
452,636
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top