Posts by graha_karya

graha_karya · Jul 12th 2019

What format want you keep

graha_karya · Jul 7th 2019

Should be

Code

Sub 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

graha_karya · Jul 3rd 2019

Code

range("j7:j" & cells(rows.count,1).end(3).row).formula="If(Rc[-1]>=RC[-2],""pass"")"

graha_karya · Jul 2nd 2019

Code

Sub 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

Display More

graha_karya · Jul 1st 2019

perhab for dinamic range wrap text like this

Code

Sub 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

Display More

graha_karya · Jul 1st 2019

Code

Sub 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

Display More

graha_karya · Jun 30th 2019

Code

Sub xxz()
 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
If not u is nothing then U.name ="Deskription"  end sub

graha_karya · Jun 30th 2019

Imposible until 10 minutes from your data only 200 range
if you want dinamik range
[For each r in range(name range)[/code]

graha_karya · Jun 29th 2019

Finaly if you want dinamic range merge cell to autofit

Code

Sub 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

Display More

graha_karya · Jun 29th 2019

t

Quote from Colin7

graha_karya,

Thanks for your reply. Is there a way to use a named range instead of listing every cell?

try this

Code

Sub 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

Display More

graha_karya · Jun 29th 2019

Code

dim fn
Fn = thisworkbook.path & "\" & myfilename
msgbox fn
Perhab you lost \

graha_karya · Jun 29th 2019

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

Code

Sub myrg(ar) as string
Dim v as variant,t as long
For each v in ar
    t=val(v)
    with Range("Z" & t)
        .value = range(v).value
        .wraptext=true
        .columnwidth=25 'change this
        .rows(t).Autofit
    End with
Next v
End sub


Sub xxx()
myrg array("c14","c61",...etc)
End sub

Display More

graha_karya · Jun 29th 2019

Quote from Colin7

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

Display More

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]

graha_karya · Jun 29th 2019

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

Code

Function 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]

graha_karya · Jun 29th 2019

if any range or 1 range edit code

Code

'=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

Display More

graha_karya · Jun 29th 2019

see this picture
[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"change.png","data-attachmentid":1219774}[/ATTACH]

graha_karya · Jun 29th 2019

finaly you can make UDF like this
only small editing in B1=test(A1;"ARD-") change red text with your text

Code

Function 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

Display More

graha_karya · Jun 29th 2019

this is answer for case in link : https://www.ozgrid.com/forum/f…umbers-in-numerical-order

Code

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
 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

Display More

[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"ssx.png","data-attachmentid":1219768}[/ATTACH]

graha_karya · Jun 29th 2019

Perhab
if.left(r.formula.....blalalala
txt=r.address
r.formula ="=round(sum(" & txt & "),0)"

graha_karya · Apr 13th 2019

Try change to

Code

sht.columns(5).specialcells(2).replace combobox1.value,textbox1.value

Posts by graha_karya

Extract columns VBA

Run macro in all worksheets

Fill down error with only 1 row of data.

merge columns within selected rows

Autofit Row Heights In Merged Cells

Autofit Row Heights In Merged Cells

Autofit Row Heights In Merged Cells

Autofit Row Heights In Merged Cells

Autofit Row Heights In Merged Cells

Autofit Row Heights In Merged Cells

image box in VBA

Autofit Row Heights In Merged Cells

answer Sort numbers in numerical and string order

answer Sort numbers in numerical and string order

answer Sort numbers in numerical and string order

answer Sort numbers in numerical and string order

answer Sort numbers in numerical and string order

answer Sort numbers in numerical and string order

Macro to add ROUND() formula

Find Replace Sheet Array