Hyside2's Profile
Expert
2676
Points

Questions
0

Answers
39

  • Expert Asked on April 29, 2018 in VBA: Macros.

    RE: VBA Code to Insert Multiple Rows of Data After Active Row/Cell

    The picture above shows how the sheet is setup.

    The picture below shows the result of the sheet if the macro is run 3 times.

    RE: VBA Code to Insert Multiple Rows of Data After Active Row/Cell

    Sub addata()
    
    Application.ScreenUpdating = False
    
    Columns("B:B").Select
    
    With Selection
    
    .HorizontalAlignment = xlCenter
    
    .VerticalAlignment = xlBottom
    
    .WrapText = False
    
    .Orientation = 0
    
    .AddIndent = False
    
    .IndentLevel = 0
    
    .ShrinkToFit = False
    
    .ReadingOrder = xlContext
    
    .MergeCells = False
    
    End With
    
    Dim cnt
    
    cnt = Cells(Rows.Count, "A").End(xlUp).Offset(-5).Select
    
    Dim num As Long
    
    num = ActiveCell.Value + 5
    
    ActiveCell.Offset(7).Select
    
    ActiveCell = num
    
    With ActiveCell
    
    .Font.Bold = True
    
    .HorizontalAlignment = xlLeft
    
    End With
    
    ActiveCell.Offset(1) = "Description:"
    
    ActiveCell.Offset(2) = "Date:"
    
    ActiveCell.Offset(2, 1) = "@"
    
    ActiveCell.Offset(3) = "Minimum:"
    
    ActiveCell.Offset(4) = "Average:"
    
    ActiveCell.Offset(5) = "Comments:"
    Range(ActiveCell.Offset(1), ActiveCell.Offset(5)).Select
    
    With Selection
    
    .HorizontalAlignment = xlRight
    
    End With
    
    With Selection.Font
    
    .ThemeColor = xlThemeColorDark1
    
    .TintAndShade = -0.499984740745262
    
    End With
    ActiveCell.Offset(-7, 9).Copy
    
    ActiveCell.Offset(0, 9).PasteSpecial
    
    ActiveCell.Offset(5, -9).Select
    Range(ActiveCell, ActiveCell.Offset(0, 9)).Select
    
    With Selection.Borders(xlEdgeBottom)
    
    .LineStyle = xlContinuous
    
    .ColorIndex = 0
    
    .TintAndShade = 0
    
    .Weight = xlThin
    
    End With
    Application.CutCopyMode = False
    
    ActiveCell.Offset(1).Select
    End Sub
    
    
    • 31 views
    • 1 answers
    • 0 votes
  • Expert Asked on April 19, 2018 in VBA: Macros.

    Oh sorry forgot the before and after pictures, Here they are.

    RE: Find Copy and Paste

     

    • 36 views
    • 3 answers
    • 0 votes
  • Expert Asked on April 19, 2018 in VBA: Macros.

    For this to work please add custom format to format cells. Add 13 zeros as the custom format. See pictures. RT click on any cell.

    RE: Find Copy and Paste

    .

    RE: Find Copy and Paste

    .

    The results of the macro are in column “F”

    Sub GetTwoSixty()
    
    Application.ScreenUpdating = False
    
    Dim ws1 As Worksheet
    
    Set ws1 = Worksheets("Sheet1")
    Dim lRow As Long
    
    lRow = ws1.UsedRange.Rows.Count
    Dim i As Integer
    On Error GoTo Line1
    
    Columns("F:F").ClearContents
    
    Application.DisplayAlerts = True
    
    ThisWorkbook.Sheets.Add(After:= _
    
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) _
    
    .Name = "Temp"
    ws1.Range("A1:D" & lRow).Copy Destination:=Worksheets("Temp").[A1]
    
    [f1].Select
    
    ActiveCell.Formula = "=right(A1,13)"
    
    ActiveCell.Copy
    
    For i = 1 To 3
    
    ActiveCell.Offset(0, 1).PasteSpecial
    Next i
    
    [f1].Select
    
    lRow = lRow - 1
    
    ActiveCell.Offset(lRow).Select
    For i = 1 To 4
    
    Range(ActiveCell, ActiveCell.End(xlUp)).FillDown
    
    ActiveCell.Offset(0, 1).Select
    
    Next i
    Range("F1").Select
    
    ActiveCell.CurrentRegion.Select
    
    Selection.Copy
    
    Range("K1").Select
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
    
    :=False, Transpose:=False
    
    Columns("K:N").Select
    
    Application.CutCopyMode = False
    
    Selection.NumberFormat = "0000000000000"
    lRow = ws1.UsedRange.Rows.Count
    
    Range("L1:L" & lRow).Copy Destination:=Cells(Rows.Count, 11).End(xlUp).Offset(1)
    
    Range("M1:M" & lRow).Copy Destination:=Cells(Rows.Count, 11).End(xlUp).Offset(1)
    
    Range("N1:N" & lRow).Copy Destination:=Cells(Rows.Count, 11).End(xlUp).Offset(1)
    Columns("K:K").Select
    
    ActiveWorkbook.Worksheets("Temp").Sort.SortFields.Clear
    
    ActiveWorkbook.Worksheets("Temp").Sort.SortFields.Add Key:=Range("K1:K100000"), _
    
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.Worksheets("Temp").Sort
    
    .SetRange Range("K1:K100000")
    
    .Header = xlGuess
    
    .MatchCase = False
    
    .Orientation = xlTopToBottom
    
    .SortMethod = xlPinYin
    
    .Apply
    
    End With
    
    Columns("L:N").ClearContents
    
    [L1].Formula = "=Left(K1,3)"
    
    Range("K1").End(xlDown).Offset(0, 1).Select
    
    Range(ActiveCell, ActiveCell.End(xlUp)).FillDown
    [L1].Select
    Do Until IsEmpty(ActiveCell)
    
    If ActiveCell.Value = 260 Then
    
    ActiveCell.Offset(1).Select
    
    Else
    
    Rows(ActiveCell.Row).EntireRow.Delete
    
    End If
    
    Loop
    
    Columns("L:L").ClearContents
    
    [K1].Select
    
    ActiveCell.CurrentRegion.Copy Destination:=ws1.Range("F1")
    
    ws1.Activate
    Application.DisplayAlerts = False
    
    ThisWorkbook.Sheets("Temp").Delete
    
    Line1:
    End Sub
    
    
    • 36 views
    • 3 answers
    • 0 votes
  • Expert Asked on April 18, 2018 in VBA: Macros.

    RE: Excel - VBA Script - Count the date and Time stamp in a single column

    RE: Excel - VBA Script - Count the date and Time stamp in a single column

    Sub CountDateTime()
    Dim ws1 As Worksheet
    
    Set ws1 = Worksheets("Sheet1")
    Dim ltr As String
    
    ltr = InputBox("What column is your Time Stamp in?", "Time Stamp Information")
    
    Dim lRow As Long
    
    lRow = Cells(Rows.Count, ltr).End(xlUp).Row
    Dim rng As Range
    
    Set rng = Range(Range(ltr & 1), Range(ltr & lRow))
    On Error GoTo Line1
    
    Application.DisplayAlerts = False
    
    ThisWorkbook.Sheets("Temp").Delete
    
    Line1:
    
    Application.DisplayAlerts = True
    
    ThisWorkbook.Sheets.Add(After:= _
    
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) _
    
    .Name = "Temp"
    ws1.Select
    
    rng.Copy Destination:=Worksheets("Temp").Range("A1")
    Call text2col
    
    Range("BY1:CC" & lRow).Copy
    
    ws1.Select
    Dim c As Long
    
    If Range("A1") <> "" Then
    
    c = 1
    
    GoTo Line31
    
    End If
    If Range("A1") = "" Then
    
    c = 2
    
    GoTo Line31
    
    End If
    If Range("B1") = "" Then
    
    c = 3
    
    GoTo Line31
    
    End If
    If Range("C1") = "" Then
    
    c = 4
    
    GoTo Line31
    
    End If
    Line31:
    Dim lColumn As Long
    
    lColumn = ws1.UsedRange.Columns.Count + c
    ws1.Cells(1, lColumn).PasteSpecial xlPasteValues
    
    [a1].Select
    
    Application.DisplayAlerts = False
    
    ThisWorkbook.Sheets("Temp").Delete
    End Sub
    
    Sub text2col() ' ' text2col Macro ' Worksheets("Temp").Select Dim lRow As Long lRow = Cells(Rows.Count, "A").End(xlUp).Row ' Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _ Semicolon:=False, Comma:=True, Space:=True, Other:=False, FieldInfo:= _ Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7 _ , 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array _ (14, 1), Array(15, 1), Array(16, 1)), TrailingMinusNumbers:=True Cells.Select [CE1].Formula = "=today()" [CE2].Formula = "=Sum(CE1+30)" [CE3].Formula = "=Sum(CE1+31)" [CE4].Formula = "=Sum(CE1+60)" [CE5].Formula = "=Sum(CE1+61)" [CE6].Formula = "=Sum(CE1+90)" [CE7].Formula = "=Sum(CE1+91)" [BY1].Formula = "=countif(A1:BW1,""UTC"")" [BY1].Select ActiveCell.Offset(lRow - 1).Select Range(ActiveCell, ActiveCell.End(xlUp)).FillDown [BZ1].Formula = "=countifs(A1:BW1,"">=""&$CD$1,A1:BW1,""<=""&$CD$2)" [BZ1].Select ActiveCell.Offset(lRow - 1).Select Range(ActiveCell, ActiveCell.End(xlUp)).FillDown [CA1].Formula = "=countifs(A1:BW1,"">=""&$CD$3,A1:BW1,""<=""&$CD$4)" [CA1].Select ActiveCell.Offset(lRow - 1).Select Range(ActiveCell, ActiveCell.End(xlUp)).FillDown [CB1].Formula = "=countifs(A1:BW1,"">=""&$CD$5,A1:BW1,""<=""&$CD$6)" [CB1].Select ActiveCell.Offset(lRow - 1).Select Range(ActiveCell, ActiveCell.End(xlUp)).FillDown [CC1].Formula = "=countifs(A1:BW1,"">=""&$CD$7)" [CC1].Select ActiveCell.Offset(lRow - 1).Select Range(ActiveCell, ActiveCell.End(xlUp)).FillDown End Sub
    • 37 views
    • 2 answers
    • 0 votes
  • Expert Asked on April 7, 2018 in VBA.

    RE: Bring data from columns to row using excel VBA

     

    Sub OrganizeGrades()
    Dim lastrow As Integer
    Dim lastcol As Integer
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim n As Integer
    Dim r As Integer
    Dim subject As String
    Dim i As Integer
    Set ws1 = Worksheets(“Sheet1”)
    Set ws2 = Worksheets(“Sheet2”)
    r = 2
    lastrow = Cells(Rows.Count, “A”).End(xlUp).Row
    lastcol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    Application.ScreenUpdating = False
    For n = 1 To lastrow
    Cells(r, 4).Select
    For i = 1 To 8
    If ActiveCell = “” Then
    ActiveCell.Offset(0, 1).Select
    Else
    Range(Cells(r, 1), Cells(r, 4)).Copy
    ws2.Cells(Rows.Count, “A”).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

    If ActiveCell.Column = “5” Then subject = “Subject”
    If ActiveCell.Column = “7” Then subject = “English”
    If ActiveCell.Column = “9” Then subject = “Math”
    If ActiveCell.Column = “11” Then subject = “Science”
    ws2.Cells(Rows.Count, “D”).End(xlUp).Offset(1).Value = subject

    Range(ActiveCell, ActiveCell.Offset(0, 1)).Copy
    ws2.Cells(Rows.Count, “E”).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

    ActiveCell.Offset(0, 2).Select

    End If

    Next i
    r = r + 1
    Next n
    ws2.Select
    Application.CutCopyMode = False
    [A1].Select
    End Sub

     

    • 29 views
    • 1 answers
    • 0 votes
  • Expert Asked on April 5, 2018 in VBA: Macros.

    Hello Krishnan

    I am not sure which variable contains the vlookup.  To resolve this, change the appropriate line below.

    If the vlookup is in this line.

    adr.Copy Destination:=ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)

    Change it to this.

    adr.Copy

    ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1). PasteSpecial xlPasteValues

     

    These are the copy and paste line in the code. One of them should be commanding the cell where the Vlookup is. Change the appropriate line as outlined above.

    adr.Copy Destination:=ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    oc.Copy Destination:=ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1)
    ocd.Copy Destination:=ws2.Cells(Rows.Count, 3).End(xlUp).Offset(1)
    WH.Copy Destination:=ws2.Cells(Rows.Count, 4).End(xlUp).Offset(1)
    rng.Copy Destination:=ws2.Cells(Rows.Count, 5).End(xlUp).Offset(1, -2)

     

    If you do no know which line to change, please let me know what the cell address is where vlookup is located.

    • 181 views
    • 24 answers
    • 0 votes
  • Expert Asked on April 5, 2018 in VBA.

    Hello GKJ,  Here is how I view the problem. It may be a bit rudimentary. Please try it.  Thank you.

     

    RE: find duplicate and update ID number

     

    Sub DuplicateRows()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long
    Dim r As Long
    Dim r1 As Long
    Dim c As Long
    Dim lastrow As Long

    On Error GoTo Line1
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(“Temp”).Delete
    Line1:
    Application.DisplayAlerts = True
    ThisWorkbook.Sheets.Add(After:= _
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) _
    .Name = “Temp”
    Set ws1 = Worksheets(“Sheet1”)
    Set ws2 = Worksheets(“Temp”)

    lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row

    r = 2
    r1 = 2
    c = lastrow
    Application.ScreenUpdating = False
    ws1.Range(“H:I”).ClearContents
    ws1.Range(“A1:F” & lastrow).Copy Destination:=ws2.[a1]
    ws2.[H1] = “Names”
    ws2.[N1] = “Row Numbers”

    For i = 1 To lastrow
    ws2.Range(Cells(r, r1), Cells(c, r1)).Copy
    ws2.Cells(Rows.Count, 8).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    r1 = r1 + 1
    Next i
    Dim hcol As Long
    hcol = ws2.Cells(Rows.Count, 8).End(xlUp).Row
    Columns(“H:H”).Select

    Application.CutCopyMode = False
    ActiveSheet.Range(“$H$1:$H” & hcol).RemoveDuplicates Columns:=1, Header:=xlYes
    [I2].FormulaR1C1 = “=IFNA(MATCH(RC8,C[-7],0),””””)”
    [I2].Copy Destination:=Range(“J2:M2”)

    Range(“I2”).Copy
    [H1].Select
    ActiveCell.End(xlDown).Offset(0, 1).Select
    Range(ActiveCell, ActiveCell.End(xlUp)).FillDown
    For i = 1 To 4
    ActiveCell.Offset(0, 1).Select
    Range(ActiveCell, ActiveCell.End(xlUp)).FillDown
    Next i

    Range(“N2”).Select
    ActiveCell.FormulaR1C1 = _
    “=CONCATENATE(“”ID “”&RC[-5]&””,””,RC[-4]&””,””,RC[-3]&””,””,RC[-2]&””,””,RC[-1])”

    [H1].Select
    ActiveCell.End(xlDown).Offset(0, 6).Select
    Range(ActiveCell, ActiveCell.End(xlUp)).FillDown
    hcol = ws2.Cells(Rows.Count, 8).End(xlUp).Row
    ws2.Range(“H1:H” & hcol).Copy Destination:=ws1.Range(“H1”)
    ws2.Range(“N1:N” & hcol).Copy
    ws1.Range(“I1”).PasteSpecial Paste:=xlPasteValues
    ws1.Columns(“H:I”).AutoFit
    ws1.Activate
    [a1].Select
    End Sub

    • 44 views
    • 2 answers
    • 0 votes
  • Expert Asked on April 2, 2018 in VBA: Macros.

    Change:

    rng.Copy Destination:=ws2.Cells(Rows.Count, 5).End(xlUp).Offset(1, -2)

     

    To:

    rng.Copy

    ws2.Cells(Rows.Count, 5).End(xlUp).Offset(1, -2).PasteSpecial xlPasteValues

    • 181 views
    • 24 answers
    • 0 votes
  • Expert Asked on March 23, 2018 in VBA: Macros.

    Sub hide()
    Sheet3.Visible = False
    Sheet4.Visible = False
    Sheet5.Visible = False
    ‘ You can hide as many sheets as you like.
    End Sub
    Sub Unhide()
    Sheet3.Visible = True
    Sheet4.Visible = True
    Sheet5.Visible = True
    End Sub

    • 36 views
    • 1 answers
    • 0 votes
  • Expert Asked on March 23, 2018 in VBA.

    ‘ This will wait 20 sec and then Save and Close the workbook. You can put in your own time delay.
    Application.Wait Now + TimeValue(“00:00:20”)
    ActiveWorkbook.Close Savechanges:=True

    This answer accepted by narsing18. on March 24, 2018 Earned 100 points.

    • 50 views
    • 2 answers
    • 0 votes
  • Expert Asked on March 19, 2018 in VBA.

    Hello Raghu, Here is what I came up with.

    Please change  workbook path ” E:\Excel\Raghu\  ” to the path that you save the workbooks to.

    RE: Need help to modify the macro.

     

    Sub ExportByName()
    
    Dim unique(1000) As String
    
    Dim wb(1000) As Workbook
    
    Dim ws As Worksheet
    
    Dim x As Long, y As Long, ct As Long, uCol As Long, gCol As Long ' Added gCol As Long to original
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    
    Application.Calculation = xlCalculationManual
    
    Set ws = ActiveWorkbook.Sheets("Sheet1") 'Your main worksheet
    
    uCol = 6 'Column F
    
    gCol = 7 'Column G Added to original(Hyside2)
    
    ct = 0
    
    'get a unique list of users
    
    For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
    
    unique(ct) = ActiveSheet.Cells(x, uCol).Text
    
    ct = ct + 1
    
    End If
    
    Next x
    
    'loop through the unique list
    
    For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1
    
    If unique(x) <> "" Then
    
    'add workbook
    
    Set wb(x) = Workbooks.Add
    
    'copy header row
    
    ws.Range(ws.Cells(1, 1), ws.Cells(1, gCol)).Copy wb(x).Sheets(1).Cells(1, 1) 'Changed uCol to gCol
    
    'loop to find matching items in ws and copy over
    
    For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    
    If ws.Cells(y, uCol) = unique(x) Then
    
    'copy full formula over
    
    'ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1)
    
    'to copy and paste values
    
    ws.Range(ws.Cells(y, 1), ws.Cells(y, gCol)).Copy 'Changed uCol to gCol
    
    wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)
    
    End If
    
    Next y
    
    'autofit
    
    wb(x).Sheets(1).Columns.AutoFit
    
    'save when done
    
    ' wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x)
    
    ' Opens sheets that already exist
    
    If Len(Dir("E:\Excel\Raghu\" & unique(x) & ".xlsx")) > 0 Then ' Hyside2 says change this dir E:\Excel\Raghu\ to your dir
    Rows("1:1").Select
    
    Selection.ClearContents
    
    [a2].Select
    
    ActiveCell.CurrentRegion.Select
    
    Selection.Copy
    
    Workbooks.Open Filename:="E:\Excel\Raghu\" & unique(x) & ".xlsx"
    
    ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    
    wb(x).Close Savechanges:=False
    
    ActiveWorkbook.Save
    
    Else
    
    'Save unique sheets only
    
    wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x)
    
    End If
    'wb(x).Close SaveChanges:=True
    
    Else
    
    'once reaching blank parts of the array, quit loop
    
    Exit For
    
    End If
    
    Next x
    
    Application.ScreenUpdating = True
    
    Application.Calculation = xlCalculationAutomatic
    
    ErrHandler:
    
    Application.ScreenUpdating = True
    
    Application.Calculation = xlCalculationAutomatic
    
    End Sub
    
    Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
    
    CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
    
    End Function
    
    • 56 views
    • 6 answers
    • 0 votes
  • Expert Asked on March 13, 2018 in Excel: General.

    Not sure how to get rid or the “X” but here is a workaround. If someone clicks on the “X” the workbook will be saved before it closes.

    RE: disable X in excel to  close excel sheet

     

    
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
    ActiveWorkbook.Save
    
    End Sub
    
    
    • 32 views
    • 1 answers
    • 0 votes