• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Insert columns in middle of report using vlookup

B

Brinda

New Member
Hi Team,

I am trying to develop a macro to cut the second part of the report which is present in the existing sheet and then by doing vlook up to insert those values in the existing report.

Explanation:

I have a report which is split into two parts. The first part starts from A1 and then second part starts from row named New. The second part of the report consists of 10 columns and the first part of the reports consists of 30 columns. I have to insert 10 columns in the first part of the report i.e. have to insert columns from second part into first set of report after Column U and before Column V.
One column is unique between both set of reports (Column named - Position Identifier) using which vlookup has to be done and values inserted.
Sample report attached and below is the coding that i am using.

The newly inserted columns must appear in the original report after C30 and before U1. After inserting columns and doing vlookup --> convert to values the second part of the report must be deleted.

I am getting error msg while using this code, but could not identify where to rectify it

Can anyone please help .



Code: 
Sub sixtyfiveMoveReport()
Dim pg2 As Range
Dim part2Report As Range
Dim destRange As Range
Dim part2Row As Long
Dim myCol As Long
Dim impPath As String
impPath = RetrieveFileName()
If impPath = "" Then Exit Sub 'User cancelled
Workbooks.Open (impPath)


Set pg2 = Range("A:A").Find("New")
part2Row = pg2.Row
Set pg2 = pg2.Offset(2, 1)
Set part2Report = Range(pg2, pg2.End(xlToRight).End(xlDown))

myCol = 22

Application.ScreenUpdating = False


Cells(1, myCol).Resize(1, part2Report.Columns.Count).EntireColumn.Insert


With part2Report
    .Rows(1).Cut
    ActiveSheet.Paste Destination:=Cells(10, myCol)
    Set destRange = Range(Cells(9, myCol), Cells(part2Row - 1, Cells(10, myCol).Offset(0, .Columns.Count - 1).Column))

    destRange.Formula = _
        "=VLOOKUP($V25," & .Offset(0, -1).Resize(, .Columns.Count + 1).Address(True) & ",COLUMN(B$2),FALSE)"
    destRange.Value = destRange.Value
    .Clear
End With

Range(part2Row & ":65536").EntireRow.Delete

Application.ScreenUpdating = True


End Sub

Private Function RetrieveFileName()
'obtained from:

Dim sFileName      As String


ChDir ThisWorkbook.Path

"sFileName"
sFileName = Application.GetOpenFilename(FileFilter:=myFilter, Title:="Multi Worksheet Import", MultiSelect:=False)


If sFileName = "False" Then Exit Function

    RetrieveFileName = sFileName
End Function
 

Attachments

  • Original report.xlsx
    221.5 KB · Views: 3
Code: 
Sub sixtyfiveMoveReport()
Dim pg2 As Range
Dim part2Report As Range
Dim destRange As Range
Dim part2Row As Long
Dim myCol As Integer, myRow As Integer, lastRow As Integer
Dim impPath As String
impPath = RetrieveFileName()
If impPath = "" Then Exit Sub 'User cancelled
With Workbooks.Open(impPath).Sheets(1)


Set pg2 = .Range("A:A").Find("New")
part2Row = pg2.Row
Set pg2 = pg2.Offset(2, 1)
Set part2Report = .Range(pg2, pg2.End(xlToRight).End(xlDown))

myCol = 22
myRow = .Range("a:a").Find("Demand Name").Row
lastRow = .Range("a:a").Find("Grand Total").Row
Application.ScreenUpdating = False


.Cells(1, myCol).Resize(1, part2Report.Columns.Count).EntireColumn.Insert


With part2Report
    .Offset(-1).Rows(1).Cut
    ActiveSheet.Paste Destination:=.Parent.Cells(myRow, myCol)
    Set destRange = .Parent.Range(.Parent.Cells(myRow + 1, myCol), .Parent.Cells(lastRow - 1, .Parent.Cells(myRow, myCol).Offset(0, .Columns.Count - 1).Column))

    destRange.Formula = _
        "=VLOOKUP($AF25," & .Offset(0, -1).Resize(, .Columns.Count + 1).Address(True) & ",COLUMN(B$2),FALSE)"
    destRange.Value = destRange.Value

    .Clear
End With

.Range(part2Row & ":65536").EntireRow.Delete
End With
Application.ScreenUpdating = True


End Sub

Private Function RetrieveFileName()
'obtained from:

Dim sFileName      As String


ChDir ThisWorkbook.Path


sFileName = Application.GetOpenFilename(FileFilter:=myFilter, Title:="Multi Worksheet Import", MultiSelect:=False)


If sFileName = "False" Then Exit Function

    RetrieveFileName = sFileName
End Function
 
Hi wudixin96,

Thanks for the code.

Now its working for me too.

Had to do one small modification(demand name was one filter, hence i deleted that row)

Thanks a ton for your help :)
 
wudixin96 Can you kindly provide assistance in one more scenario

I am trying to develop a macro to cut the second part of the report which is present in the existing sheet and then by doing vlook up to insert those values in the existing report. However vlookup has to be split.

That is, total 12 columns has to be vlookedup, 9 before column named position identifier and 3 after that column

Explanation:

I have a report which is split into two parts. The first part starts from A1 and then second part starts from row named New. The second part of the report consists of 12 columns and the first part of the reports consists of 30 columns. I have to insert 9 columns in the first part of the report i.e. have to insert columns from second part into first set of report before Column Y (named - position identifier)and 3 after column Y abd before Column Z.
One column is unique between both set of reports (Column named - Position Identifier) using which vlookup has to be done and values inserted.
Sample report attached.

After inserting columns and doing vlookup --> convert to values the second part of the report must be deleted.

Kindly assist
 

Attachments

  • 65kreport-original.xlsx
    86.7 KB · Views: 2
Code: 
Sub sixtyfiveMoveReport()
Dim pg2 As Range
Dim part2Report As Range
Dim destRange1 As Range, destRange2 As Range
Dim part2Row As Long
Dim myCol As Integer, myRow As Integer, lastRow As Integer
Dim impPath As String
Dim numCols1 As Integer, numCols2 As Integer
impPath = RetrieveFileName()
If impPath = "" Then Exit Sub 'User cancelled

With Workbooks.Open(impPath).Sheets(1)

    Set pg2 = .Range("A:A").Find("New")
    part2Row = pg2.Row
    Set pg2 = pg2.Offset(2, 1)
    Set part2Report = .Range(pg2, pg2.End(xlToRight).End(xlDown))
   
    myRow = .Range("a:a").Find("Demand Name").Row
    myCol = .Rows(myRow & ":" & myRow).Find("Position Identifier").Column
   
    lastRow = part2Row - 1
   
    Application.ScreenUpdating = False
   
    numCols1 = 9
    numCols2 = 3
   
    .Cells(1, myCol).Resize(1, numCols1).EntireColumn.Insert shift:=xlShiftToRight
    .Cells(1, myCol + numCols1 + 1).Resize(1, numCols2).EntireColumn.Insert shift:=xlShiftToRight
   
    With part2Report
        .Cells(1).Resize(1, numCols1).Rows(1).Copy
        .Parent.Paste Destination:=.Parent.Cells(myRow, myCol)
       
        .Cells(1).Offset(0, numCols1).Resize(1, numCols2).Rows(1).Copy
        .Parent.Paste Destination:=.Parent.Cells(myRow, myCol + numCols1 + 1)
       
        Set destRange1 = .Parent.Range(.Parent.Cells(myRow + 1, myCol), .Parent.Cells(lastRow - 1, .Parent.Cells(myRow, myCol).Offset(0, numCols1 - 1).Column))
   
        destRange1.Formula = _
            "=VLOOKUP($AH" & myRow + 1 & "," & .Offset(0, -1).Resize(, .Columns.Count + 1).Address(True) & ",COLUMN(B$2),FALSE)"
        destRange1.Value = destRange1.Value
   
        Set destRange2 = .Parent.Range(.Parent.Cells(myRow + 1, myCol + numCols1 + 1), .Parent.Cells(lastRow - 1, .Parent.Cells(myRow, myCol + numCols1 + 1).Offset(0, numCols2 - 1).Column))
   
        destRange2.Formula = _
            "=VLOOKUP($AH" & myRow + 1 & "," & .Offset(0, -1).Resize(, .Columns.Count + 1).Address(True) & ",COLUMN(K$2),FALSE)"
        destRange2.Value = destRange2.Value
       
        .Clear
    End With
   
    .Range(part2Row & ":65536").EntireRow.Delete
End With
Application.ScreenUpdating = True


End Sub

Private Function RetrieveFileName()
'obtained from:

Dim sFileName      As String


ChDir ThisWorkbook.Path


sFileName = Application.GetOpenFilename(FileFilter:=myFilter, Title:="Multi Worksheet Import", MultiSelect:=False)


If sFileName = "False" Then Exit Function

    RetrieveFileName = sFileName
End Function
 
Sorry for the late reply wudixin96
The code is working fine... Thank u very much.
Can you do me one more help pls
I am trying to format a report.
Specifications are change the column width of the report from columns A-R to 10 and from columns S-CB to 5
Add autofilter in row 23 , Report must be visible from row 22 only and freeze pane must be applied in row 24
Final hide columns B-R.

I tried the below coding but all the columns are getting hidden and column width is also not coming correct.

Please advise/help as to where i am making mistake

Code: 
Sub Code()
'
' Code Macro
'

'
    Cells.Select
    Cells.EntireRow.AutoFit
    Range("A1:CB1").Select
        Selection.UnMerge
    Range("A2:CB2").Select
        Selection.UnMerge
    Range("A20:R22").Select
        Selection.UnMerge
    Range("A23").Select
    Cells.Find(What:="grand total", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        Selection.UnMerge
    Cells.Select
    Selection.ColumnWidth = 5
    Columns("A:R").Select
    Range("R3").Activate
    Selection.ColumnWidth = 10
    Range("N19").Select
    ActiveWindow.SmallScroll Down:=21
    Rows("24:24").Select
    ActiveWindow.FreezePanes = True
    Rows("23:23").Select
    Selection.AutoFilter
    Columns("B:R").Select
    Selection.EntireColumn.Hidden = True
    Columns("A:A").Select
    Range("A24").Select
End Sub
 
that's what you mean ?
Code: 
Sub mycode()
    With ActiveSheet
        If .AutoFilterMode Then
            .Rows("23:23").EntireRow.AutoFilter
        End If
        .Rows("23:23").AutoFilter
        .Rows("24:24").Select
        ActiveWindow.FreezePanes = True
        .Columns("A:R").ColumnWidth = 10
        .Columns("S:CB").ColumnWidth = 5
        .Columns("B:R").Hidden = True
    End With
End Sub
 
You must log in or register to reply here.
Back
Top