What format want you keep
Posts by graha_karya
-
-
Should be
CodeSub MisRec() Dim ws As Worksheet For Each ws In Worksheets ws.activate Cells.Find(What:="abc", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , SearchFormat:=False).Activate ActiveCell.Offset(-2, 0).Select Range(ActiveCell, "A2").Select Selection.EntireRow.Delete Next ws End Sub
-
-
Code
Display MoreSub test() dim rg as range,i a s long Set rg=[b1:L26] For i = rg.rows.count to 1 step -1 If rg(i,1).interior.colorindex=rg(i+1).colorindex then Application.displayAllerts = false Rg(i+1,1).resize(2).merge rg(i+1,2).resize(2).merge rg(i+1,rg.columns.count).resize(2).merge Application.displayallerts= true End if Next i End sub
-
perhab for dinamic range wrap text like this
Code
Display MoreSub test1() Dim ar, rg As Range, Nm As String, c As Double, b As Long, i As Long Dim r As Range, U As Range, ans As String On Error GoTo Finish With Application .DisplayAlerts = False .ScreenUpdating = False .Calculation = xlCalculationManual End With Nm = "test" ans = MsgBox("are you want make name manager" & vbNewLine & "if make name manager press vbyes" & vbNewLine & _ "if only Autofit Press vbNo ", vbYesNo, "Choose") If ans = vbYes Then For Each r In Range("C:C").SpecialCells(2) If r.MergeCells = True Then If U Is Nothing Then Set U = r.MergeArea Else Set U = Union(r.MergeArea, U) End If Next r If Not U Is Nothing Then U.Select With Selection ActiveWorkbook.Names(Nm).Delete .Name = Nm End With Else ' if name manager has saved as name =Nm then executed this code For Each rg In Range(Nm).Areas b = b + 1 If b = 1 Then 'this handle only for first loop For i = rg.Columns.Count To 1 Step -1 c = c + rg.Columns(i).ColumnWidth Next i End If With Cells(rg(1, 1).Row, Columns.Count) .Value = rg(1, 1).Value .ColumnWidth = c .WrapText = True .EntireRow.AutoFit End With Next rg End If Finish: With Application .DisplayAlerts = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub
-
Code
Display MoreSub test() Dim ar, rg As Range, Nm As String, c As Double Dim r As Range, U As Range, ans As String On Error GoTo Finish With Application .DisplayAlerts = False .ScreenUpdating = False .Calculation = xlCalculationManual End With Nm = "test" ans = MsgBox("are you want make name manager", vbYesNo, "Make range Name") If ans = vbYes Then For Each r In Range("C:C").SpecialCells(2) If r.MergeCells = True Then If U Is Nothing Then Set U = r.MergeArea Else Set U = Union(r.MergeArea, U) End If Next r If Not U Is Nothing Then U.Select With Selection ActiveWorkbook.Names(Nm).Delete .Name = Nm End With Else For Each rg In Range(Nm).Areas With Cells(rg(1, 1).Row, Columns.Count) .Value = rg(1, 1).Value .ColumnWidth = rg(1, 1).ColumnWidth + rg(1, 2).ColumnWidth .WrapText = True .EntireRow.AutoFit End With Next rg End If Finish: With Application .DisplayAlerts = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub
-
-
Imposible until 10 minutes from your data only 200 range
if you want dinamik range
[For each r in range(name range)[/code] -
Finaly if you want dinamic range merge cell to autofit
Code
Display MoreSub test() Dim ar, rg As Range, t, c As Double Dim r As Range, U As Range On Error GoTo Finish With Application .DisplayAlerts = False .ScreenUpdating = False .Calculation = xlCalculationManual End With For Each r In [B]Range("C:C").SpecialCells(2) 'change with first column Autofit[/B] If r.MergeCells = True Then If U Is Nothing Then Set U = r.Cells(1) Else Set U = Union(U, r.Cells(1)) End If Next r [COLOR=#FF0000][B]c = Range("C1").ColumnWidth + Range("D1").ColumnWidth + Range("E1").ColumnWidth 'change this area[/B][/COLOR] If Not U Is Nothing Then For Each r In U.Areas With Range("Z" & r(1, 1).Row) .Value = r.Value .WrapText = True .ColumnWidth = c / 1.05 [B]'add row height [/B] .EntireRow.AutoFit End With Next r End If Set U = Nothing Finish: With Application .DisplayAlerts = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub
-
t
graha_karya,
Thanks for your reply. Is there a way to use a named range instead of listing every cell?
try thisCode
Display MoreSub test() Dim ar, rg As Range, t, c As Double On Error GoTo Finish With Application .DisplayAlerts = False .ScreenUpdating = False .Calculation = xlCalculationManual End With ar = Array("C14", "C61", "C108", "C155", "C202", "C249", "C296", "C343", "C390", "C437", "C534", "C484", "C531", "C578", "C625", "C672", "C719", "C766", "C813", "C860", "C907", "C954", "C1001", "C1048", _ "C1095", "C1142", "C1189", "C1236", "C1283", "C1330", "C1377", "C1424", "C1471", "C1518", "C1565", "C1612", "C1659", "C1706", "C1753", "C1800", "C1847", "C1894", "C1941", "C1988", "C2035", "C2082", "C2129", _ "C2176", "C2223", "C2270", "C2317", "C2364", "C2411", "C2458", "C2505", "C2552", "C2599", "C2646", "C2693", "C2740", "C2787", "C2834", "C2881", "C2928", "C2975", "C3022", "C3069", "C3116", "C3163", "C3210", _ "C3257", "C3304", "C3351", "C3398", "C3445", "C3492", "C3539", "C3586", "C3633", "C3680", "C3727", "C3774", "C3821", "C3868", "C3915", "C3962", "C4009", "C4056", "C4103", "C4150", "C4197", "C4244", "C4291", _ "C4338", "C4385", "C4432", "C4479", "C4526", "C4573", "C4620", "C4667", "C4714", "C4761", "C4808", "C4855", "C4902", "C4949", "C4996", "C5043", "C5090", "C5137", "C5184", "C5231", "C5278", "C5325", "C5372", _ "C5419", "C5466", "C5513", "C5560", "C5607", "C5654", "C5701", "C5748", "C5795", "C5842", "C5889", "C5936", "C5983", "C6030", "C6077", "C6124", "C6171", "C6218", "C6265", "C6312", "C6359", "C6406", "C6453", _ "C6500", "C6547", "C6594", "C6641", "C6688", "C6735", "C6782", "C6829", "C6876", "C6923", "C6970", "C7017", "C7064", "C7111", "C7158", "C7205", "C7252", "C7299", "C7346", "C7393", "C7440", "C7487", "C7534", _ "C7581", "C7628", "C7675", "C7722", "C7769", "C7816", "C7863", "C7910", "C7957", "C8004", "C8051", "C8098", "C8145", "C8192", "C8239", "C8286", "C8333", "C8380", "C8427", "C8474", "C8521", "C8568", "C8615", _ "C8662", "C8709", "C8756", "C8803", "C8850", "C8897", "C8944", "C8991", "C9038", "C9085", "C9132", "C9179", "C9226", "C9273", "C9320") [COLOR=#B22222][B]c = Range("C1").ColumnWidth + Range("D1").ColumnWidth + Range("E1").ColumnWidth 'change this with your area mergearea[/B][/COLOR] For Each V In ar t = "Z" & Replace(V, "C", "") [B] 'change Z with your dummy range[/B] With Range(t) .Value = Range(V).Value .WrapText = True .ColumnWidth = (Range("C1").ColumnWidth + Range("D1").ColumnWidth + Range("E1").ColumnWidth)[COLOR=#FF0000][B] / 1.2 'For little space[/B][/COLOR] .EntireRow.AutoFit End With Next V 'Range("Z:Z").ClearContents Finish: With Application .DisplayAlerts = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub
-
-
For quickly try this if your merge area struktur as same as example in col c,d and e
example you have merge in c1:e1
Step 1 : you must know columnwidth in col c,d,e by clik in format columnwidth
For example total column width = 25
Step 2 = in z1 = +c1
Step 3 wrap text in z1 and clik autofit row
You can record then -
How does this work?
on sheet 1 cell C23 I need the formula =test("GSA-",sheet2,E16:E416)
on sheet 1 cell C13 I need the formula =test("GSA-",sheet2,E520:E920)
on sheet 1 cell C33 I need the formula =test("GSA-",sheet2,E1100:E1500)
and so on
i dont understand you want
in post #7 i has edit my code
C23=test("GSA-",sheet2,E16:E416)
C13=test("GSA-",sheet2E520:E920)
C33=test("GSA-",sheet2,E1100:E1500)
[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"cxx.png","data-attachmentid":1219785}[/ATTACH] -
1 minute ago
My only problem is that there are 20 of these formulas on one sheet which pull numbers from different ranges. So I would have to type in the letters to 20 different formulas each time. Is there a way to do this that isn't a UDF and it would automatically put the numbers in numerical order regardless of which letters there are?if you has any or multi range using parramArray
CodeFunction test(Textreplace As String, fx As Variant) As String change to [B]Function test1(Textreplace As String, ParamArray fx() As Variant) As String[/B] but you must edit little code you can do in cell with multi range and multi sheet [B]= test1("A",shee1A1:a10,sheet2b10:b30,{"F90";"F90";"F90A"})
[/B]
[/code] -
if any range or 1 range edit code
Code
Display More'=test("GSA-",A9:A13) Function test(Textreplace As String, fx As Variant) As String Dim x As Variant, sp, i As Long, ii As Long, ans As String Dim r As Long, c As Long, fd As Boolean, dic As Object: Set dic = CreateObject("scripting.dictionary") Dim tt As String, ar() As Variant If fx.Count = 1 Then If Len(Textreplace) Then x = Trim$(Replace(fx.Value, Textreplace, "")) fd = True Else x = fx.Value: fd = False End If Else Rg = fx.Value For i = LBound(Rg) To UBound(Rg) If Len(Rg(i, 1)) Then td = Replace(Rg(i, 1), Textreplace, "") If x = "" Then x = td Else x = x & "," & td End If Next i End If sp = Split(x, ",") ReDim ar(1 To UBound(sp) + 1, 1 To 2) For i = 0 To UBound(sp) r = r + 1 txt = Trim$(sp(i)) If Not IsNumeric(Right(txt, 1)) Then ar(r, 1) = Val(txt) ar(r, 2) = Replace(txt, ar(r, 1), "") Else ar(r, 1) = Val(txt) End If Next i Urutkan ar, 1 For i = 1 To UBound(ar, 1) If Not ar(i, 2) = vbNullString Then For ii = i + 1 To UBound(ar, 1) If ar(i, 2) > ar(ii, 2) And ar(i, 1) = ar(ii, 1) Then temp = ar(i, 2): ar(i, 2) = ar(ii, 2): ar(ii, 2) = temp End If Next ii End If Next i For i = 1 To UBound(ar) dic(ar(i, 1) & ar(i, 2)) = "" Next i Erase ar For Each v In dic If fd = True Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v If fd = False Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v Next v test = tt End Function Function Urutkan(ar() As Variant, cl As Long) Dim a As Long, b As Long, c As Long For a = 1 To UBound(ar, 1) For b = a + 1 To UBound(ar, 1) If ar(a, cl) > ar(b, cl) Then For c = 1 To UBound(ar, 2) temp = ar(a, c) ar(a, c) = ar(b, c): ar(b, c) = temp Next c End If Next b Next a End Function
-
see this picture
[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"change.png","data-attachmentid":1219774}[/ATTACH] -
finaly you can make UDF like this
only small editing in B1=test(A1;"ARD-") change red text with your textCode
Display MoreFunction test(ByVal fx As String, Textreplace As String) As String Dim x As Variant, sp, i As Long, ii As Long, ans As String Dim r As Long, c As Long, fd As Boolean, dic As Object: Set dic = CreateObject("scripting.dictionary") Dim tt As String, ar() As Variant Application.Volatile x = Replace(fx, Textreplace, "") If Len(Textreplace) Then x = Trim$(Replace(x, Textreplace, "")) fd = True Else x = x: fd = False End If sp = Split(x, ",") ReDim ar(1 To UBound(sp) + 1, 1 To 2) For i = 0 To UBound(sp) r = r + 1 txt = Trim$(sp(i)) If Not IsNumeric(Right(txt, 1)) Then ar(r, 1) = Val(txt) ar(r, 2) = Replace(txt, ar(r, 1), "") Else ar(r, 1) = Val(txt) End If Next i Urutkan ar, 1 For i = 1 To UBound(ar, 1) If Not ar(i, 2) = vbNullString Then For ii = i + 1 To UBound(ar, 1) If ar(i, 2) > ar(ii, 2) And ar(i, 1) = ar(ii, 1) Then temp = ar(i, 2): ar(i, 2) = ar(ii, 2): ar(ii, 2) = temp End If Next ii End If Next i For i = 1 To UBound(ar) dic(ar(i, 1) & ar(i, 2)) = "" Next i Erase ar For Each v In dic If fd = True Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v If fd = False Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v Next v test = tt End Function Function Urutkan(ar() As Variant, cl As Long) Dim a As Long, b As Long, c As Long For a = 1 To UBound(ar, 1) For b = a + 1 To UBound(ar, 1) If ar(a, cl) > ar(b, cl) Then For c = 1 To UBound(ar, 2) temp = ar(a, c) ar(a, c) = ar(b, c): ar(b, c) = temp Next c End If Next b Next a End Function
-
this is answer for case in link : https://www.ozgrid.com/forum/f…umbers-in-numerical-order
Code
Display MoreFunction Urutkan(ar() As Variant, cl As Long) Dim a As Long, b As Long, c As Long For a = 1 To UBound(ar, 1) For b = a + 1 To UBound(ar, 1) If ar(a, cl) > ar(b, cl) Then For c = 1 To UBound(ar, 2) temp = ar(a, c) ar(a, c) = ar(b, c): ar(b, c) = temp Next c End If Next b Next a End Function Sub xx1() Dim Rg As Range, Tr As String, x As Variant, ar(), sp, i As Long, ii As Long, ans As String Dim r As Long, c As Long, fd As Boolean, dic As Object: Set dic = CreateObject("scripting.dictionary") Set Rg = [a1]: Tr = "ARD" x = Replace(Rg.Value, " ", "") ans = MsgBox("Are you Replace", vbYesNo) If ans = vbYes Then x = Replace(x, Tr, "") fd = True Else x = x: fd = False End If sp = Split(x, ",") ReDim ar(1 To UBound(sp) + 1, 1 To 2) For i = 0 To UBound(sp) r = r + 1 txt = Trim$(sp(i)) If Not IsNumeric(Right(txt, 1)) Then ar(r, 1) = Val(txt) ar(r, 2) = Replace(txt, ar(r, 1), "") Else ar(r, 1) = Val(txt) End If Next i Urutkan ar, 1 For i = 1 To UBound(ar, 1) If Not ar(i, 2) = vbNullString Then For ii = i + 1 To UBound(ar, 1) If ar(i, 2) > ar(ii, 2) And ar(i, 1) = ar(ii, 1) Then temp = ar(i, 2): ar(i, 2) = ar(ii, 2): ar(ii, 2) = temp End If Next ii End If Next i For i = 1 To UBound(ar) dic(ar(i, 1) & ar(i, 2)) = "" Next i Erase ar For Each v In dic If fd = True Then If tt = "" Then tt = Tr & v Else tt = tt & "," & Tr & v Else If tt = "" Then tt = v Else tt = tt & "," & v End If Next v Rg(1, 2).Value = tt End Sub
[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"ssx.png","data-attachmentid":1219768}[/ATTACH] -
Perhab
if.left(r.formula.....blalalala
txt=r.address
r.formula ="=round(sum(" & txt & "),0)" -