How to Copy and paste particular Columns in the Same worksheet based on Cell values from another worksheet

Rakesh Kamani

Rakesh Kamani

New Member
Joined
Feb 25, 2020
Messages
33
Office Version
  1. 2013
Platform
  1. Windows
Hi All,
I am new to VBA, I already have a code, we are going to add some logic in this code. Below I am going to explain the requirement. Please help with this.
I would like to copy Column-K to Column-V and paste it same worksheet from Column-W to AH and so on, which created new "FG" sheet in the same workbook based on another worksheet("07_Safety_Sheet") range(A5:A12). if "A5" value update is manually it will automatically copy Column-K to Column-V and paste into same worksheet from Column-W to AH. Please correction and add logic to the code. otherwise please provide module to copy Column-K to V and let me know where we going to call in the code.
Thank you for your help in advance.

VBA Code: 
Private Sub CommandButton1_Click()
'declaring veriables
Dim wB As Workbook

Dim wS As Worksheet

Dim wT As Worksheet

Dim wD As Worksheet

Dim wDB As Worksheet

Dim wSM As Worksheet

Dim strF As String

Dim strT As String

Dim strTemp As String

Dim intI As Integer

Dim intJ As Integer

Dim intC As Integer

Dim intS As Integer

Dim intR As Integer

Dim intX As Integer

Dim intY As Integer

Dim rngDB As Range

Dim rngCell As Range

Dim rngSM As Range
Dim rngCellSM As Range

Dim strFormulea As String

On Error Resume Next

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

'Assigning sheet, that has data available

Set wS = ThisWorkbook.Worksheets("Source_Sheet")

Set wT = ThisWorkbook.Worksheets("template_Sheet_xxx")

Set wDB = ThisWorkbook.Worksheets("04_Component_Sheet")

Set wSM = ThisWorkbook.Worksheets("07_Safety_Sheet")

Set rngDB = wDB.Range("B85:B188")

Set rngSM = wSM.Range("A5:A14")

strF = "FG"

intS = 1

intI = 0

intJ = 0

Do

If wS.Range("A7").Offset(intI, 0).Value = "" Or wS.Range("A7").Offset(intI, 0).Value = "EoF" Then Exit Do

strT = wS.Range("A7").Offset(intI, 0).Value

If VBA.InStr(1, strT, strF) Then

DelExistSheet ThisWorkbook, strT

'To add new sheet, if there is no exiting sheet for the given Functional Group

'Set wD = ThisWorkbook.Worksheets.Add(after:=wS)

Set wD = Worksheets.Add(after:=Worksheets(Worksheets.Count))

intJ = 1

Do

If VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, strF) Or VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, "EoF") Then Exit Do

' intC = 0

intJ = intJ + 1

Loop

intC = intJ - 1

wD.Name = strT

'To add header row to each added sheet

wT.Range("A1:V6").Copy wD.Range("A1")

'copying rows from Source_Sheet, one by one add pasting to next available line on Created FG sheet

wS.Range("A7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("B7")

wS.Range("I7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("A7")

wS.Range("B7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("C7")

wS.Range("C7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("D7")

'wD.Range("F7").Resize(intC).Value = wS.Range("L7").Offset(intI + 1, 0).Resize(intC, 1).Value

'wD.Range("G7").Resize(intC).Value = wS.Range("V7").Offset(intI + 1, 0).Resize(intC, 1).Value

'strTemp = VBA.Left(strFormulea, VBA.InStr(1, strFormulea, ",") - 1)

'strTemp = VBA.Replace(strTemp, "VLOOKUP(", "")

'strFormulea = VBA.Replace(strFormulea, strTemp, "RC[-5]")

'wD.Range("F7").Resize(intC, 1).FormulaR1C1 = strFormulea

'strFormulea = wS.Range("L7").Offset(intI + 1, 0).FormulaR1C1

'strTemp = VBA.Replace(strTemp, "VLOOKUP(", "")

'strFormulea = VBA.Replace(strFormulea, strTemp, "RC[-6]")

'wD.Range("G7").Resize(intC, 1).FormulaR1C1 = strFormulea

intX = 0

Do

If wD.Range("A7").Offset(intX, 0).Value = "" Then Exit Do

For Each rngCell In rngDB

If VBA.InStr(1, rngCell.Value, wD.Range("A7").Offset(intX, 0).Value) Then

intR = rngCell.Row

intY = rngCell.MergeArea.Cells.Count

Exit For

End If

Next rngCell

wD.Range("A7").Offset(intX + 1, 0).Resize(intY - 1, 26).Insert Shift:=xlDown

wD.Range("H7").Offset(intX, 0).Resize(intY, 1).Value = wDB.Cells(intR, 4).Resize(intY, 1).Value

wD.Range("I7").Offset(intX, 0).Resize(intY, 1).Value = wDB.Cells(intR, 5).Resize(intY, 1).Value

strFormulea = "= VLOOKUP(RC[-5],'Source_Sheet'!R5C9:R83C22,4,0)"

wD.Range("F7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "= VLOOKUP(RC[-6],'Source_Sheet'!R5C9:R83C22,14,0)"

wD.Range("G7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "=R" & 7 + intX & "C7*RC9*RC[-3]"

wD.Range("O7").Offset(intX, 0).Resize(intY, 3).FormulaR1C1 = strFormulea

strFormulea = "=IF(RC[-1]<>" & """""" & ",VLOOKUP(RC[-1],'07_Safety_Sheet'!R18C2:R40C3,2,FALSE),0)"

wD.Range("S7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "=RC[-5]*(100%-RC[-1])"

wD.Range("T7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "=RC[-5]*(100%-RC[-2])"

wD.Range("U7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

intX = intX + intY

Loop

intX = 0

Do

If wD.Range("H7").Offset(intX, 0).Value = "" Then Exit Do

intY = 1

Do

If wD.Cells(7 + intX + intY, 1).Value <> "" Or wD.Range("H7").Offset(intX + intY, 0).Value = "" Then Exit Do

intY = intY + 1

Loop

'Merge Column cells from A to G

wD.Cells(7 + intX, 1).Resize(intY, 1).Merge

wD.Cells(7 + intX, 1).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 1).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 2).Resize(intY, 1).Merge

wD.Cells(7 + intX, 2).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 2).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 3).Resize(intY, 1).Merge

wD.Cells(7 + intX, 3).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 3).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 4).Resize(intY, 1).Merge

wD.Cells(7 + intX, 4).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 4).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 5).Resize(intY, 1).Merge

wD.Cells(7 + intX, 5).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 5).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 6).Resize(intY, 1).Merge

wD.Cells(7 + intX, 6).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 6).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 7).Resize(intY, 1).Merge

wD.Cells(7 + intX, 7).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 7).Resize(intY, 1).VerticalAlignment = xlCenter

intX = intX + intY '+ 1

Loop

End If

intI = intI + intJ

Loop

'Application.ScreenUpdating = True

With Application

.ScreenUpdating = True

.DisplayAlerts = False

End With

MsgBox "created Functional Group from Source_Sheet"

End Sub

Sub DelExistSheet(wB As Workbook, SheetName As String)

On Error Resume Next

Dim wS As Worksheet

Set wS = wB.Worksheets(SheetName)

wS.Delete

End Sub
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Rakesh Kamani said:
Hi All,
I am new to VBA, I already have a code, we are going to add some logic in this code. Below I am going to explain the requirement. Please help with this.
I would like to copy Column-K to Column-V and paste it same worksheet from Column-W to AH and so on, which created new "FG" sheet in the same workbook based on another worksheet("07_Safety_Sheet") range(A5:A12). if "A5" value update is manually it will automatically copy Column-K to Column-V and paste into same worksheet from Column-W to AH. Please correction and add logic to the code. otherwise please provide module to copy Column-K to V and let me know where we going to call in the code.
Thank you for your help in advance.

VBA Code: 
Private Sub CommandButton1_Click()
'declaring veriables
Dim wB As Workbook

Dim wS As Worksheet

Dim wT As Worksheet

Dim wD As Worksheet

Dim wDB As Worksheet

Dim wSM As Worksheet

Dim strF As String

Dim strT As String

Dim strTemp As String

Dim intI As Integer

Dim intJ As Integer

Dim intC As Integer

Dim intS As Integer

Dim intR As Integer

Dim intX As Integer

Dim intY As Integer

Dim rngDB As Range

Dim rngCell As Range

Dim rngSM As Range
Dim rngCellSM As Range

Dim strFormulea As String

On Error Resume Next

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

'Assigning sheet, that has data available

Set wS = ThisWorkbook.Worksheets("Source_Sheet")

Set wT = ThisWorkbook.Worksheets("template_Sheet_xxx")

Set wDB = ThisWorkbook.Worksheets("04_Component_Sheet")

Set wSM = ThisWorkbook.Worksheets("07_Safety_Sheet")

Set rngDB = wDB.Range("B85:B188")

Set rngSM = wSM.Range("A5:A14")

strF = "FG"

intS = 1

intI = 0

intJ = 0

Do

If wS.Range("A7").Offset(intI, 0).Value = "" Or wS.Range("A7").Offset(intI, 0).Value = "EoF" Then Exit Do

strT = wS.Range("A7").Offset(intI, 0).Value

If VBA.InStr(1, strT, strF) Then

DelExistSheet ThisWorkbook, strT

'To add new sheet, if there is no exiting sheet for the given Functional Group

'Set wD = ThisWorkbook.Worksheets.Add(after:=wS)

Set wD = Worksheets.Add(after:=Worksheets(Worksheets.Count))

intJ = 1

Do

If VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, strF) Or VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, "EoF") Then Exit Do

' intC = 0

intJ = intJ + 1

Loop

intC = intJ - 1

wD.Name = strT

'To add header row to each added sheet

wT.Range("A1:V6").Copy wD.Range("A1")

'copying rows from Source_Sheet, one by one add pasting to next available line on Created FG sheet

wS.Range("A7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("B7")

wS.Range("I7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("A7")

wS.Range("B7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("C7")

wS.Range("C7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("D7")

'wD.Range("F7").Resize(intC).Value = wS.Range("L7").Offset(intI + 1, 0).Resize(intC, 1).Value

'wD.Range("G7").Resize(intC).Value = wS.Range("V7").Offset(intI + 1, 0).Resize(intC, 1).Value

'strTemp = VBA.Left(strFormulea, VBA.InStr(1, strFormulea, ",") - 1)

'strTemp = VBA.Replace(strTemp, "VLOOKUP(", "")

'strFormulea = VBA.Replace(strFormulea, strTemp, "RC[-5]")

'wD.Range("F7").Resize(intC, 1).FormulaR1C1 = strFormulea

'strFormulea = wS.Range("L7").Offset(intI + 1, 0).FormulaR1C1

'strTemp = VBA.Replace(strTemp, "VLOOKUP(", "")

'strFormulea = VBA.Replace(strFormulea, strTemp, "RC[-6]")

'wD.Range("G7").Resize(intC, 1).FormulaR1C1 = strFormulea

intX = 0

Do

If wD.Range("A7").Offset(intX, 0).Value = "" Then Exit Do

For Each rngCell In rngDB

If VBA.InStr(1, rngCell.Value, wD.Range("A7").Offset(intX, 0).Value) Then

intR = rngCell.Row

intY = rngCell.MergeArea.Cells.Count

Exit For

End If

Next rngCell

wD.Range("A7").Offset(intX + 1, 0).Resize(intY - 1, 26).Insert Shift:=xlDown

wD.Range("H7").Offset(intX, 0).Resize(intY, 1).Value = wDB.Cells(intR, 4).Resize(intY, 1).Value

wD.Range("I7").Offset(intX, 0).Resize(intY, 1).Value = wDB.Cells(intR, 5).Resize(intY, 1).Value

strFormulea = "= VLOOKUP(RC[-5],'Source_Sheet'!R5C9:R83C22,4,0)"

wD.Range("F7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "= VLOOKUP(RC[-6],'Source_Sheet'!R5C9:R83C22,14,0)"

wD.Range("G7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "=R" & 7 + intX & "C7*RC9*RC[-3]"

wD.Range("O7").Offset(intX, 0).Resize(intY, 3).FormulaR1C1 = strFormulea

strFormulea = "=IF(RC[-1]<>" & """""" & ",VLOOKUP(RC[-1],'07_Safety_Sheet'!R18C2:R40C3,2,FALSE),0)"

wD.Range("S7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "=RC[-5]*(100%-RC[-1])"

wD.Range("T7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

strFormulea = "=RC[-5]*(100%-RC[-2])"

wD.Range("U7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

intX = intX + intY

Loop

intX = 0

Do

If wD.Range("H7").Offset(intX, 0).Value = "" Then Exit Do

intY = 1

Do

If wD.Cells(7 + intX + intY, 1).Value <> "" Or wD.Range("H7").Offset(intX + intY, 0).Value = "" Then Exit Do

intY = intY + 1

Loop

'Merge Column cells from A to G

wD.Cells(7 + intX, 1).Resize(intY, 1).Merge

wD.Cells(7 + intX, 1).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 1).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 2).Resize(intY, 1).Merge

wD.Cells(7 + intX, 2).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 2).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 3).Resize(intY, 1).Merge

wD.Cells(7 + intX, 3).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 3).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 4).Resize(intY, 1).Merge

wD.Cells(7 + intX, 4).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 4).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 5).Resize(intY, 1).Merge

wD.Cells(7 + intX, 5).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 5).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 6).Resize(intY, 1).Merge

wD.Cells(7 + intX, 6).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 6).Resize(intY, 1).VerticalAlignment = xlCenter


wD.Cells(7 + intX, 7).Resize(intY, 1).Merge

wD.Cells(7 + intX, 7).Resize(intY, 1).HorizontalAlignment = xlCenter

wD.Cells(7 + intX, 7).Resize(intY, 1).VerticalAlignment = xlCenter

intX = intX + intY '+ 1

Loop

End If

intI = intI + intJ

Loop

'Application.ScreenUpdating = True

With Application

.ScreenUpdating = True

.DisplayAlerts = False

End With

MsgBox "created Functional Group from Source_Sheet"

End Sub

Sub DelExistSheet(wB As Workbook, SheetName As String)

On Error Resume Next

Dim wS As Worksheet

Set wS = wB.Worksheets(SheetName)

wS.Delete

End Sub
Click to expand...
Now below code is working, I have added sub and function.

VBA Code: 
Private Sub CommandButton1_Click()

'declaring veriables

Dim wB As Workbook

Dim wS As Worksheet
Dim wT As Worksheet
Dim wD As Worksheet ' Create new FG sheet
Dim wDB As Worksheet


'Variable for Rows, Columns
Dim strF As String  'String variables for the filter name
Dim strT As String
Dim strTemp As String
Dim intI As Integer
Dim intJ As Integer
Dim intC As Integer
Dim intS As Integer
Dim intR As Integer
Dim intX As Integer
Dim intY As Integer
Dim intIndex As Integer


'Variable for our 04_Component_Sheet data range
Dim rngDB As Range
Dim rngCell As Range


Dim strFormulea As String

On Error Resume Next    'The procedure in which the On Error statement is used catches the error, even when other procedures are called

    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    End With
    
'Assigning sheet names, that has data available
Set wS = ThisWorkbook.Worksheets("Source_Sheet")
Set wT = ThisWorkbook.Worksheets("template_Sheet")
Set wDB = ThisWorkbook.Worksheets("04_Component_Sheet")


Set rngDB = wDB.Range("B85:B188")


'Assign values where search criteria for filtering
strF = "FG"
intS = 1
intI = 0
intJ = 0

Do  'loop until all rows have been parsed
   If wS.Range("A7").Offset(intI, 0).Value = "" Or wS.Range("A7").Offset(intI, 0).Value = "EoF" Then Exit Do
   strT = wS.Range("A7").Offset(intI, 0).Value  'FG value set to strT variable
   If VBA.InStr(1, strT, strF) Then     'If the Value does not exist then...
   
   
  'DelExistSheet ThisWorkbook, strT
  
  intIndex = getSheetIndex(ThisWorkbook, strT)
  If intIndex < 1 Then
  
  
  'To add new sheet, if there is no exiting sheet for the given Functional Group
    'Set wD = ThisWorkbook.Worksheets.Add(after:=wS)
   Set wD = Worksheets.Add(after:=Worksheets(Worksheets.Count))
      intJ = 1
      Do
      
         If VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, strF) Or VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, "EoF") Then Exit Do
         
          'intC = 0
         intJ = intJ + 1
         
      
      Loop
      intC = intJ - 1
      wD.Name = strT
      
      'To add header row from template sheet to each added FG sheets
      
      wT.Range("A1:V6").Copy wD.Range("A1")
      
      'copying rows from Source_Sheet, one by one add pasting to next available line on Created FG sheet
      'the Offset Property returned a Range Object shifted 1 row down, and the resize property further retuned a range object of one row smaller, so as not to remove haedings
      wS.Range("A7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("B7")
      wS.Range("I7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("A7")
      wS.Range("B7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("C7")
      wS.Range("C7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("D7")
      
      'wD.Range("F7").Resize(intC).Value = wS.Range("L7").Offset(intI + 1, 0).Resize(intC, 1).Value
      
      'wD.Range("G7").Resize(intC).Value = wS.Range("V7").Offset(intI + 1, 0).Resize(intC, 1).Value


     'Set a placeholder value for intX
      intX = 0
      Do    'Start the loop
         If wD.Range("A7").Offset(intX, 0).Value = "" Then Exit Do
         
         For Each rngCell In rngDB
            'Check to see if end of list.  if so, exit loop
            'VBA Instr Function checks if a string of text is found in another string of text.
            'It returns 0 if the text is not found. Otherwise it returns the character position where the text is found.
            'The Instr Function performs exact matches.
            If VBA.InStr(1, rngCell.Value, wD.Range("A7").Offset(intX, 0).Value) Then
               
               intR = rngCell.Row
               intY = rngCell.MergeArea.Cells.Count
             
               Exit For
            End If  'GoTo EndofLoop
         
         Next rngCell
         
        
         wD.Range("A7").Offset(intX + 1, 0).Resize(intY - 1, 26).Insert Shift:=xlDown
         
         wD.Range("H7").Offset(intX, 0).Resize(intY, 1).Value = wDB.Cells(intR, 4).Resize(intY, 1).Value
         
         wD.Range("I7").Offset(intX, 0).Resize(intY, 1).Value = wDB.Cells(intR, 5).Resize(intY, 1).Value
         
         
         strFormulea = "= VLOOKUP(RC[-5],'Source_Sheet'!R5C9:R83C22,4,0)"
         wD.Range("F7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea
         
 
         strFormulea = "= VLOOKUP(RC[-6],'Source_Sheet'!R5C9:R83C22,14,0)"
         wD.Range("G7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea
         
         'Formula updated for O,P & Q
         strFormulea = "=R" & 7 + intX & "C7*RC9*RC[-3]"
         wD.Range("O7").Offset(intX, 0).Resize(intY, 3).FormulaR1C1 = strFormulea
         
           'Formula updated for "S"
                    strFormulea = "=IF(RC[-1]<>" & """""" & ",VLOOKUP(RC[-1],'07_Safety_Sheet'!R18C2:R40C3,2,FALSE),0)"
         wD.Range("S7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

      
         'Formula updated for "T" & "U"
            strFormulea = "=RC[-5]*(100%-RC[-1])"
         
            wD.Range("T7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea
            
            strFormulea = "=RC[-5]*(100%-RC[-2])"
            
            wD.Range("U7").Offset(intX, 0).Resize(intY, 1).FormulaR1C1 = strFormulea

         
         intX = intX + intY
         
      Loop
      'Set a placeholder value for intX
      intX = 0
      
      Do    'Start the loop
      
         If wD.Range("H7").Offset(intX, 0).Value = "" Then Exit Do
         'Set a placeholder value for intY
         intY = 1
         
         Do
            'Check to see if end of list.  if so, exit loop
            If wD.Cells(7 + intX + intY, 1).Value <> "" Or wD.Range("H7").Offset(intX + intY, 0).Value = "" Then Exit Do
            intY = intY + 1
            
         
         Loop
       'Merge Column cells from A to G
         wD.Cells(7 + intX, 1).Resize(intY, 1).Merge
         wD.Cells(7 + intX, 1).Resize(intY, 1).HorizontalAlignment = xlCenter
         wD.Cells(7 + intX, 1).Resize(intY, 1).VerticalAlignment = xlCenter

         wD.Cells(7 + intX, 2).Resize(intY, 1).Merge
         wD.Cells(7 + intX, 2).Resize(intY, 1).HorizontalAlignment = xlCenter
         wD.Cells(7 + intX, 2).Resize(intY, 1).VerticalAlignment = xlCenter
         
         wD.Cells(7 + intX, 3).Resize(intY, 1).Merge
         wD.Cells(7 + intX, 3).Resize(intY, 1).HorizontalAlignment = xlCenter
         wD.Cells(7 + intX, 3).Resize(intY, 1).VerticalAlignment = xlCenter
         
         wD.Cells(7 + intX, 4).Resize(intY, 1).Merge
         wD.Cells(7 + intX, 4).Resize(intY, 1).HorizontalAlignment = xlCenter
         wD.Cells(7 + intX, 4).Resize(intY, 1).VerticalAlignment = xlCenter
         
         wD.Cells(7 + intX, 5).Resize(intY, 1).Merge
         wD.Cells(7 + intX, 5).Resize(intY, 1).HorizontalAlignment = xlCenter
         wD.Cells(7 + intX, 5).Resize(intY, 1).VerticalAlignment = xlCenter
         
         wD.Cells(7 + intX, 6).Resize(intY, 1).Merge
         wD.Cells(7 + intX, 6).Resize(intY, 1).HorizontalAlignment = xlCenter
         wD.Cells(7 + intX, 6).Resize(intY, 1).VerticalAlignment = xlCenter
         
         wD.Cells(7 + intX, 7).Resize(intY, 1).Merge
         wD.Cells(7 + intX, 7).Resize(intY, 1).HorizontalAlignment = xlCenter
         wD.Cells(7 + intX, 7).Resize(intY, 1).VerticalAlignment = xlCenter
         intX = intX + intY '+ 1
      
      Loop
      
      addSG wD
      
      Else
      
        Set wD = ThisWorkbook.Worksheets(intIndex)
        addSG wD
        
        intJ = 1
        Do
        
           If VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, strF) Or VBA.InStr(1, wS.Range("A7").Offset(intI + intJ, 0).Value, "EoF") Then Exit Do
        
      intJ = intJ + 1
      
      
      Loop
 

      'GoTo EndofLoop
   End If
   
   End If
   
   
   intI = intI + intJ
Loop
'Application.ScreenUpdating = True  'This is not too important but can speed things up a bit by disabling the updating of the screen which otherwise frequently happens
With Application
    .ScreenUpdating = True  'If this is not done the screen may be "dead" after the code finishes
    .DisplayAlerts = False  'We turn off being alerted
End With

MsgBox "created Functional Group from Source_Sheet"


End Sub

Sub DelExistSheet(wB As Workbook, sheetName As String)

    On Error Resume Next
    
    Dim wS As Worksheet
    
    Set wS = wB.Worksheets(sheetName)
    
    wS.Delete

End Sub

Sub addSG(wS As Worksheet) ',addType as integer)

Dim wSG As Worksheet
Dim intI As Integer
Dim intR As Long
Dim intX As Integer
Dim rngSrc As Range

Set wSG = ThisWorkbook.Worksheets("07_Safety_Sheet")
intR = wS.UsedRange.Rows.Count

intI = 0
intX = 0
Set rngSrc = wS.Range("K5:V" & intR)
'Select Case addType

'Case 0

Do

    If wSG.Range("A5").Offset(intI, 0).Value = "" Then Exit Do
    
        rngSrc.Copy
        wS.Cells(5, 11 + intX).PasteSpecial xlPasteAll
        
        wS.Cells(5, 11 + intX) = wSG.Range("A5").Offset(intI, 0).Value & "-goal statement"
        wS.Cells(5, 11 + intX).Resize(1, 12).Merge
        
            intI = intI + 1
            intX = intX + 12
            Loop
            
        'Case 1
        '
        '
        'End Select
        

End Sub

Function getSheetIndex(wB As Workbook, sheetName As String)

On Error Resume Next

Dim wS As Worksheet

getSheetIndex = -1

getSheetIndex = wB.Worksheets(sheetName).Index


End Function
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

Rakesh Kamani
  • Question Question
Formula cell values not updated, after change another cell value.
Replies
0
Views
661
Rakesh Kamani
Rakesh Kamani
Rakesh Kamani
  • Solved
Due to Vlookup formula unable to copy cell value
2
Replies
15
Views
1K
Rakesh Kamani
Rakesh Kamani
S
  • Solved
Copy hyperlinks from one table column to another. The columns are identical
Replies
2
Views
395
sspatriots
S
L
  • Locked
  • Question Question
Help Cleaning Up Code
Replies
2
Views
576
RoryA
RoryA
D
  • Solved
Copy row based on cell value and paste as text in another worksheet
Replies
2
Views
899
DH937
D

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

Share this page

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