code deletes a column on sheet2

N

Noni

Board Regular
Joined
Aug 27, 2022
Messages
63
Office Version
  1. 2021
Platform
  1. Windows
Hi, when I run the code, it somehow deletes the " 2021 Clients" cell E1 on Sheet2. can it be fixed ,please?
WorksheetDummy.xlsm
ABCDEFGH
12022 Clients2022 Data2022 Data22022 Data32021 Clients2021 Data2021 Data22021 Data3
2Michael123412342345James231
3Sarah43215467Sam343
4Mary9876034Peter654351
5Rachel56781245Peter1352
6Anna230Shaw440
7Monica23564545Sally143451
8Charles123400Michelle13664
9Peter6543230Ivona543
10Anthony1234230Anna34534
11Ben12345634Claire464
12Elizabeth6543078Ben123415
13Wong12762345612Ben543526
14Sally98542356Michael34346378
15Ben343David5465412343
16Jay4325876589Annaleise0487
17Anthony123Russell34656478
18Michelle1265125664Chris515
19David127612343Beth4156
20Jennifer1234876556John3235
21Anthony9897Bob32456
22Sue3478Anthony123567
23Ruba3254239Anthony98567
24Henry9876780Josh3567
25Chloe3245345676Sue33478
26Anna567Choung477
27Candy23893565Robin
28Monica465612
29Peter768
30Joe2345341
31Peter5664
Sheet1

thats how first row on Sheet 2 is
WorksheetDummy.xlsm
ABCDEFGH
12022 Clients2022 Data2022 Data22022 Data32021 Clients2021 Data2021 Data22021 Data3
Sheet2

but after running the code
WorksheetDummy.xlsm
ABCDEFG
12022 Clients2022 Data2022 Data22022 Data32021 Data2021 Data22021 Data3
2Peter6543230
3Peter768
4Peter5664
5Sally98542356
6Michelle1265125664
Sheet2

VBA Code: 
Sub CopyOldNewClients()

    Dim shtOld As Worksheet, shtNew As Worksheet
    Dim rngOld As Range, rngLookup As Range, rngNew As Range
    Dim lrowOld As Long, lrowLookup As Long, lcolNew As Long
    Application.ScreenUpdating = False
    
    Set shtOld = Worksheets("Sheet1")
    Set shtNew = Worksheets("Sheet2")
    
    lrowOld = shtOld.Range("A" & Rows.Count).End(xlUp).Row
    Set rngOld = shtOld.Range("A2:D" & lrowOld)
    lrowLookup = shtOld.Range("E" & Rows.Count).End(xlUp).Row
    Set rngLookup = shtOld.Range("E2:E" & lrowLookup)
    
    
    rngOld.Copy
    shtNew.Range("A2").PasteSpecial
    
    lcolNew = rngOld.Columns.Count + 1
    Set rngNew = shtNew.Range(rngOld.Address).Resize(, lcolNew)
    
    rngNew.Columns(lcolNew).Formula = "=IfError(Match(" & rngNew.Cells(1, 1).Address(0, 1) & "," & rngLookup.Address(external:=True) & ", 0), 999999)"
    rngNew.Columns(lcolNew).Value = rngNew.Columns(lcolNew).Value
    
    Set rngNew = rngNew.Offset(-1).Resize(rngNew.Rows.Count + 1)
    
    shtNew.Sort.SortFields.Clear
    shtNew.Sort.SortFields.Add2 Key:=rngNew.Columns(lcolNew) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange rngNew
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
' XXX Additional code to colour code the old and new clients
    Dim rowFirstNew As Long
    Dim lrowNew As Long
    
    lrowNew = shtNew.Cells(Rows.Count, lcolNew).End(xlUp).Row
    With Application
        rowFirstNew = .IfError(.Match(999999, rngNew.Columns(lcolNew), 0), 0)
        If rowFirstNew <> 0 Then
           With rngNew
                .Range(.Cells(1, 1), .Cells(rowFirstNew - 1, lcolNew)).Interior.Color = RGB(239, 255, 254)
                .Range(.Cells(rowFirstNew, 1), .Cells(lrowNew, lcolNew)).Interior.Color = RGB(250, 255, 203)
            End With
        End If
    End With
    ' XXX End of additional code
    
    rngNew.Columns(lcolNew).EntireColumn.Delete
    
    shtNew.Activate
    shtNew.Range("A1").Select
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = False

End Sub
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
Have't tried you code yet, but could it be...


VBA Code: 
'Change this
Set rngOld = shtOld.Range("A2:D" & lrowOld
'to this
Set rngOld = shtOld.Range("A2:D2" & lrowOld
 
Upvote 0
VBA Code: 
rngNew.Columns(lcolNew).EntireColumn.Delete

What did you intend for this line to do?
 
Upvote 0
Try adding the line in red. The lines above and below are just there to show where to put it.
PS: I have some history with this. The initial data samples did not have the additional 2021 columns in the output sheet.

Rich (BB code): 
    rngOld.Copy
    shtNew.Range("A2").PasteSpecial

    lcolNew = rngOld.Columns.Count + 1
    shtNew.Columns(lcolNew).Insert              ' <--- XXX Insert temporary sort column
    Set rngNew = shtNew.Range(rngOld.Address).Resize(, lcolNew)
 
Last edited:
Upvote 0
Solution
Alex Blakenburg said:
Try adding the line in red. The lines above and below are just there to show where to put it.
PS: I have some history with this. The initial data samples did not have the additional 2021 columns in the output sheet.

Rich (BB code): 
    rngOld.Copy
    shtNew.Range("A2").PasteSpecial

    lcolNew = rngOld.Columns.Count + 1
    shtNew.Columns(lcolNew).Insert              ' <--- XXX Insert temporary sort column
    Set rngNew = shtNew.Range(rngOld.Address).Resize(, lcolNew)
Click to expand...
It is not working..
 
Upvote 0
Noni said:
It is not working..
Click to expand...
"Not working" does not give me much to go on.
Are you getting an error ? if so show me the message and what line it highlighted when you hit debug ?
If not what is it that is not working.
I have updated my data to your post #1 data and run that code and it works as far as I can tell.

Perphas also repost the code you are now using after you implemented the change.
 
Upvote 0
Alex Blakenburg said:
"Not working" does not give me much to go on.
Are you getting an error ? if so show me the message and what line it highlighted when you hit debug ?
If not what is it that is not working.
I have updated my data to your post #1 data and run that code and it works as far as I can tell.

Perphas also repost the code you are now using after you implemented the change.
Click to expand...
It still deletes the column on sheet2.
 
Upvote 0
Noni said:
It still deletes the column on sheet2.
Click to expand...
VBA Code: 
Sub CopyOldNewClients()

    Dim shtOld As Worksheet, shtNew As Worksheet
    Dim rngOld As Range, rngLookup As Range, rngNew As Range
    Dim lrowOld As Long, lrowLookup As Long, lcolNew As Long
    Application.ScreenUpdating = False
    
    Set shtOld = Worksheets("Sheet1")
    Set shtNew = Worksheets("Sheet2")
    
    lrowOld = shtOld.Range("A" & Rows.Count).End(xlUp).Row
    Set rngOld = shtOld.Range("A2:D" & lrowOld)
    lrowLookup = shtOld.Range("E" & Rows.Count).End(xlUp).Row
    Set rngLookup = shtOld.Range("E2:E" & lrowLookup)
    
    
    rngOld.Copy
    shtNew.Range("A2").PasteSpecial
    
    lcolNew = rngOld.Columns.Count + 1
    shtNew.Columns(lcolNew).Insert
    Set rngNew = shtNew.Range(rngOld.Address).Resize(, lcolNew)
    
    rngNew.Columns(lcolNew).Formula = "=IfError(Match(" & rngNew.Cells(1, 1).Address(0, 1) & "," & rngLookup.Address(external:=True) & ", 0), 999999)"
    rngNew.Columns(lcolNew).Value = rngNew.Columns(lcolNew).Value
    
    Set rngNew = rngNew.Offset(-1).Resize(rngNew.Rows.Count + 1)
    
    shtNew.Sort.SortFields.Clear
    shtNew.Sort.SortFields.Add2 Key:=rngNew.Columns(lcolNew) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange rngNew
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    rngNew.Columns(lcolNew).EntireColumn.Delete
    
    shtNew.Activate
    shtNew.Range("A1").Select
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = False

End Sub
 
Upvote 0
Noni said:
VBA Code: 
Sub CopyOldNewClients()

    Dim shtOld As Worksheet, shtNew As Worksheet
    Dim rngOld As Range, rngLookup As Range, rngNew As Range
    Dim lrowOld As Long, lrowLookup As Long, lcolNew As Long
    Application.ScreenUpdating = False
   
    Set shtOld = Worksheets("Sheet1")
    Set shtNew = Worksheets("Sheet2")
   
    lrowOld = shtOld.Range("A" & Rows.Count).End(xlUp).Row
    Set rngOld = shtOld.Range("A2:D" & lrowOld)
    lrowLookup = shtOld.Range("E" & Rows.Count).End(xlUp).Row
    Set rngLookup = shtOld.Range("E2:E" & lrowLookup)
   
   
    rngOld.Copy
    shtNew.Range("A2").PasteSpecial
   
    lcolNew = rngOld.Columns.Count + 1
    shtNew.Columns(lcolNew).Insert
    Set rngNew = shtNew.Range(rngOld.Address).Resize(, lcolNew)
   
    rngNew.Columns(lcolNew).Formula = "=IfError(Match(" & rngNew.Cells(1, 1).Address(0, 1) & "," & rngLookup.Address(external:=True) & ", 0), 999999)"
    rngNew.Columns(lcolNew).Value = rngNew.Columns(lcolNew).Value
   
    Set rngNew = rngNew.Offset(-1).Resize(rngNew.Rows.Count + 1)
   
    shtNew.Sort.SortFields.Clear
    shtNew.Sort.SortFields.Add2 Key:=rngNew.Columns(lcolNew) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange rngNew
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    rngNew.Columns(lcolNew).EntireColumn.Delete
   
    shtNew.Activate
    shtNew.Range("A1").Select
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = False

End Sub
Click to expand...
Sorry, My Bad!! i had to assign updated macro to command button. All sorted! Thank you @Alex Blakenburg
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
Use Sheet1:D5 to find matching cell in Sheet2 Column A:A, and select cell (or row)
Replies
1
Views
429
brianv
B
M
  • Question Question
Code to stack by row first rather than by column?
Replies
1
Views
923
MeghanES
M
M
  • Solved
How do I get this code to skip blank cells?
Replies
8
Views
956
MeghanES
M
Guna13
  • Locked
  • Question Question
Need Help Deleting Empty Columns Based on Condition in Excel Spreadsheet by VBA code
2
Replies
12
Views
1K
Fluff
Fluff
L
  • Question Question
VBA Code Fix - calculating a group of rows, excluding amount if column contains keywords
Replies
1
Views
454
DanteAmor
DanteAmor

Forum statistics

Threads
1,224,828
Messages
6,181,215
Members
453,024
Latest member
Wingit77

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