Rakesh Kamani
New Member
- Joined
- Feb 25, 2020
- Messages
- 33
- Office Version
- 2013
- Platform
- Windows
Hi,
when I run the command button the data is copied from one sheet to another sheet, but the cell value column "L" and column "V" do not copy into another sheet (i.e Column "F" and column "G") are available due to the Vlookup formula's on Column "L" and column "V". Could you please any one correction below code
wS.Range("L7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("F7")
wS.Range("V7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("G7")
Full Code:
when I run the command button the data is copied from one sheet to another sheet, but the cell value column "L" and column "V" do not copy into another sheet (i.e Column "F" and column "G") are available due to the Vlookup formula's on Column "L" and column "V". Could you please any one correction below code
wS.Range("L7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("F7")
wS.Range("V7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("G7")
Full Code:
VBA Code:
Private Sub CommandButton1_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim wB As Workbook
Dim wS As Worksheet
Dim wT As Worksheet
Dim wD As Worksheet
Dim wDB As Worksheet
Dim strF As String
Dim strT 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
Set wS = ThisWorkbook.Worksheets("SourceSheet")
Set wT = ThisWorkbook.Worksheets("templateSheet")
Set wDB = ThisWorkbook.Worksheets("DatabaseSheet")
'Set wB = Application.Workbooks.Add
Set rngDB = wDB.Range("B85:B181")
'Do
'If wB.Worksheets.Count = 1 Then Exit Do
'wB.Worksheets(2).Delete
'Loop
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
'If intS = 1 Then
'Set wD = wB.Worksheets(1)
'intS = intS + 1
'Else
'Set wD = wB.Worksheets.Add
'End If
Set wD = ThisWorkbook.Worksheets.Add
' Set wD = ThisWorkbook.Worksheets.Add
' intC = 0
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
wT.Range("A1:V6").Copy wD.Range("A1")
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")
wS.Range("L7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("F7")
wS.Range("V7").Offset(intI + 1, 0).Resize(intC, 1).Copy wD.Range("G7")
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
intX = intX + intY
Loop
End If
intI = intI + intJ
Loop
Application.ScreenUpdating = True
MsgBox "created Functional Group from SourceSheet"
End Sub
Last edited by a moderator:
