PDA

View Full Version : [SOLVED] Need Help in making minor modification to an excel vba code.



Nick G
04-11-2019, 10:10 PM
Hello all,
I found the below vba code on the same forum where one can unmerge and fill down the duplicates values. The problem is that my data has addresses which have pin code at the end and floor no in the beginning, so when it unmerge and autofills it down it increases the numbers like. The 1st floor becomes 2nd floor,3rd floor and like that at the beginning and the pin code increases from 400028 to 400029 etc.

The data is large so I can not do it manually. The below code is otherwise working perfectly the only thing I want is that I don't want the autofill to be incremental.

So is there any way I can make modification to the below code to just fill down anything without increasing the values in autofill. Please help.

Thanks in advance.

Public Sub ProcessData()
Dim cell As Range
Dim MergedCell As Range
Dim NumRows As Long
Dim NumCols As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With ActiveSheet

For Each cell In Range("A1").Resize( _
.Cells.SpecialCells(xlCellTypeLastCell).Row, _
.Cells.SpecialCells(xlCellTypeLastCell).Column)

If cell.MergeCells Then

NumRows = cell.MergeArea.Rows.Count
NumCols = cell.MergeArea.Columns.Count
cell.UnMerge
If NumRows > 1 Then cell.AutoFill cell.Resize(NumRows)
If NumCols > 1 Then cell.Resize(NumRows).AutoFill cell.Resize(NumRows, NumCols)
End If
Next cell
End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

大灰狼1976
04-11-2019, 10:31 PM
Hi Nick G!
Welcome to vbax forum.
Not sure

If NumRows > 1 Then cell.AutoFill Destination:=cell.Resize(NumRows), Type:=xlFillCopy
If NumCols > 1 Then cell.Resize(NumRows).AutoFill Destination:=cell.Resize(NumRows, NumCols), Type:=xlFillCopy

Nick G
04-11-2019, 10:47 PM
Thanks for the welcome and for the prompt reply. Oh God bless your soul. It's working like a charm now. I can't thank you enough.

大灰狼1976
04-11-2019, 10:50 PM
@Nick. Can you post an attachment for my test?

Nick G
04-11-2019, 11:14 PM
Sorry, As it was the file from the work I can't share the exact file. But when I go home today I could try to replicate the same and if it comes out that way, I will share it with you. Thanks again

大灰狼1976
04-12-2019, 12:27 AM
I made an example and did not find problem what you said.

Sorry, I didn't see your update, please ignore this reply.


--Okami

大灰狼1976
04-12-2019, 12:55 AM
I think it's better to change it to this way.

If cell.MergeCells Then
NumRows = cell.MergeArea.Rows.Count
NumCols = cell.MergeArea.Columns.Count
cell.UnMerge
cell.Resize(NumRows, NumCols) = cell
End If