I'm automating copying a certain HTML table to Excel then the duplicates must be deleted or be excluded in being copied. The code below, copy the values from html table to a certain cells then transpose/copy it again to another cells. But I cannot figure out the way on how to exclude duplicate values from being paste to the final cells.
There is a button wherein the copied value will be paste to excel. There are 10 rows in every html table.
code:
Option Explicit
Private Sub hand_over_Click()
Application.ScreenUpdating = False
Dim e, m, a As Integer, k As Variant
Range("XET1").Select
ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True
Columns("E").NumberFormat = "MMM DD YYYY H:MM:SS AM/PM"
Columns("I").NumberFormat = "DDD"
e = 6
m = 1
While Not Range("C" & e) = ""
e = e + 1
Wend
For a = 5 To 1000
If ActiveSheet.Cells(a, 5).Value <> "" Then
If Range("XEV" & m) <> "" Then
Range("C" & e).Value = Range("XEU" & m).Value
Range("F" & e).Value = Range("XFD" & m).Value
k = Split(Split(Split(Range("XEV" & m).Value2, ") :")(1), "):")(0), " Req(")
Range("E" & e) = DateValue(Mid(k(1), 5, 7) & Right(k(1), 4)) + TimeValue(Mid(k(1), 12, 8))
Range("D" & e) = k(0)
Range("I" & e).Value = Date
e = e + 1
m = m + 1
End If
End If
Next a
ActiveSheet.Range("XET1:XFD50").Clear
Application.ScreenUpdating = True
End Sub
How about RemoveDuplicates before transpose/copy it..
Range("XET1:XFD50").Select
ActiveSheet.Range("XET1:XFD50").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11), Header:=xlY
Related
I have the below code set which takes a list of ticket data, and randomly selected three rows based on the username in Col D.
However, with a recent change in our ticketing system, I now need to update it to not select certain tickets. Specifically, I need only INC and SCTASK tickets to be selected, and not RITM tickets.
I am not quite sure how to add the filter so that tickets with RITM in the ticket number (ticket numbers are in Col A) are not included in this search.
Sub DailyTicketAudit()
'Set parameters and variables
Const sDataSheet As String = "Page 1"
Const sUserCol As String = "D"
Const lHeaderRow As Long = 1
Const lShowRowsPerUser As Long = 3
Const bSortDataByUser As Boolean = False
Dim wb As Workbook, ws As Worksheet
Dim rData As Range, rShow As Range
Dim aData() As Variant, aUserRows() As Variant
Dim i As Long, j As Long, k As Long, lRandIndex As Long, lTotalUnqUsers As Long, lMaxUserRows As Long
Set wb = Workbooks.Open("D:\Users\stefan.bagnato\Desktop\Raw Data Files\Audit Tickets Created")
Set ws = ActiveWorkbook.Sheets(sDataSheet)
Sheets("Page 1").name = "Audit Tickets"
'Work with the data range set by parameters
With ws.Range(sUserCol & lHeaderRow + 1, ws.Cells(ws.Rows.Count, sUserCol).End(xlUp))
If .Row < lHeaderRow + 1 Then
MsgBox "No data found in [" & sDataSheet & "]" & Chr(10) & _
"Verify column containing users is Column [" & sUserCol & "] or correct sUserCol in code." & Chr(10) & _
"Verify header row is Row [" & lHeaderRow & "] or correct lHeaderRow in code." & Chr(10) & _
"Once corrections have been made and data is available, try again."
Exit Sub
End If
lTotalUnqUsers = Evaluate("SUMPRODUCT((" & .Address(external:=True) & "<>"""")/COUNTIF(" & .Address(external:=True) & "," & .Address(external:=True) & "&""""))")
lMaxUserRows = Evaluate("max(countif(" & .Address(external:=True) & "," & .Address(external:=True) & "))")
If bSortDataByUser Then .Sort .Cells, xlAscending, Header:=xlNo
Set rData = .Cells
aData = .Value
ReDim aUserRows(1 To lTotalUnqUsers, 1 To 3, 1 To lMaxUserRows)
End With
'Load all available rows into the results array, grouped by the user
For i = LBound(aData, 1) To UBound(aData, 1)
For j = LBound(aUserRows, 1) To UBound(aUserRows, 1)
If IsEmpty(aUserRows(j, 1, 1)) Or aUserRows(j, 1, 1) = aData(i, 1) Then
If IsEmpty(aUserRows(j, 1, 1)) Then aUserRows(j, 1, 1) = aData(i, 1)
k = aUserRows(j, 2, 1) + 1
aUserRows(j, 2, 1) = k
aUserRows(j, 3, k) = i + lHeaderRow
Exit For
End If
Next j
Next i
'Select random rows up to lShowRowsPerUser for each user from the grouped results array
For j = LBound(aUserRows, 1) To UBound(aUserRows, 1)
Do
Randomize
lRandIndex = Int(Rnd() * aUserRows(j, 2, 1)) + 1
If Not rShow Is Nothing Then
Set rShow = Union(rShow, ws.Cells(aUserRows(j, 3, lRandIndex), sUserCol))
Else
Set rShow = ws.Cells(aUserRows(j, 3, lRandIndex), sUserCol)
End If
Loop While rShow.Cells.Count < j * Application.Min(lShowRowsPerUser, aUserRows(j, 2, 1))
Next j
rData.EntireRow.Hidden = True
rShow.EntireRow.Hidden = False
'Format table
'Sort by Opened By
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("Audit Tickets").Sort.SortFields.Add Key:=Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending
With Worksheets("Audit Tickets").Sort
.SetRange Range("A2:G" & LastRow)
.Orientation = xlTopToBottom
.Apply
End With
'Widen columns
Range("A:B,G:G").ColumnWidth = 15
Columns("C:D").ColumnWidth = 18
Columns("E:E").ColumnWidth = 50
Columns("F:F").ColumnWidth = 22
'Wrap text
Range("E1:E" & LastRow).WrapText = True
End Sub
Far more efficient, assuming aData holds all the data and the first column is tickets, is to simply process only the two of interest with the following.
Change 1 in aData(i, 1) to whichever column holds the items of interest in the array.
For i = LBound(aData, 1) To UBound(aData, 1)
If aData(i, 1) = "INC" Or aData(i, 1) = "SCTASK" Then
For j = LBound(aUserRows, 1) To UBound(aUserRows, 1)
''other code
End If
Next i
You could use advanced filter:
Sheets("Emps").Range("A1:D8").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Emps").Range("F5:F6"), CopyToRange:=Range("A1:B1"), _
Unique:=False
Data to selectively copy:
Data copied:
Reference this short YouTube video; You can record a marco to help yourself with the code also:
https://www.youtube.com/watch?v=bGUKjXmEi2E
A more thorough tutorial is found here:
http://www.contextures.com/xladvfilter01.html
This tutorial shows how to get the source data from outside Excel:
https://www.extendoffice.com/documents/excel/4189-excel-dynamic-filter-to-new-sheet.html
This tutorial shows how to split data values based on a column to different sheets (Fruit column; Apple sheet, Pear sheet, etc.):
https://www.extendoffice.com/documents/excel/2884-excel-save-filtered-data-new-sheet-workbook.html
I have an Excel VBA code that retrieves data from an external workbook into a worksheet by month.
I would like to retrieve the month of November but I can't seem to type the date to be #30/11/2017#. The date would automatically change to #11/30/2017#.
The date has to be in dd/mm/yyyy as that is the format of date in the external workbook.
Sub zz()
Dim arr, c, b(), n&
Application.ScreenUpdating = False
Worksheets("Sheet2").Range("A6").AutoFilter
Workbooks.Open "C:\Users\sophia.tan\Desktop\excel masterplan\External
workbook.xlsx", 0, 1
arr = Sheets("MaximMainTable").UsedRange
ActiveWorkbook.Close 0
c = Array(0, 2, 12, 13, 6, 7, 10, 1, 8, 9, 15, 16, 18, 19, 14, 27, 24, 25,
26, 3, 4, 36)
d = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19,
20, 21, 23)
ReDim b(1 To UBound(arr), 1 To 23)
Selection.NumberFormat = "dd/mm/yyyy"
For i = 2 To UBound(arr)
If arr(i, 12) >= (#1/11/2017#) And arr(i, 12) <= Format(#11/30/2017#) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
Dim startRow As Long, lastRow2 As Long
startRow = 6
lastRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
For i = startRow To lastRow
If Range("A" & i) Like "MX*" Then
If Range("J" & i) Like "*Rib*" Then
Range("M" & i) = "Rib"
ElseIf Range("J" & i) Like "*Spandex*Pique*" Then
Range("M" & i) = "Spandex Pique"
ElseIf ("J" & i) Like "*Pique*" Then
Range("M" & i) = "Pique"
ElseIf ("J" & i) Like "*Spandex*Jersey*" Then
Range("M" & i) = "Spandex Jersey"
ElseIf Range("J" & i) Like "*Jersey*" Then
Range("M" & i) = "Jersey"
ElseIf ("J" & i) Like "*Interlock*" Then
Range("M" & i) = "Interlock"
ElseIf ("J" & i) Like "*French*Terry*" Then
Range("M" & i) = "Fleece"
ElseIf ("J" & i) Like "*Fleece*" Then
Range("M" & i) = "Fleece"
Else
Range("M" & i) = "Collar & Cuff"
End If
End If
Next
With Worksheets("Sheet2")
.Range("A6:T" & Rows.Count).CurrentRegion.AutoFilter field:=1, Criteria1:="
<>OFM"
.Range("A6:T" &
Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter
field:=13, Criteria1:="<>Collar & Cuff"
.Range("A6:T" & Rows.Count).CurrentRegion.Offset(1,
0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Range("A6").Resize(n, 23) = b
.Range("A5").CurrentRegion.Sort key1:=Range("G5"), order1:=xlAscending,
Header:=xlYes
End With
Application.ScreenUpdating = 1
End Sub
When you use #date# notation directly, VBA expects it in mm/DD/yyyy format.
To test if a date on your worksheet is in the month of November 2017:
If arr(i, 12) >= #11/1/2017# And arr(i, 12) <= #11/30/2017# Then
'do whatever
End If
So long as the dates in Excel are "real dates", the format of the date in the worksheet cell is irrelevant.
If the dates in Excel are text, you will need to convert them to real dates before you do the comparison. Whether you do that on the worksheet, or in your code, is irrelevant.
For the date literal in your code, you can substitute other variables that resolve to a VBA Date data type. Note that if you convert a String, the String must be in an unambiguous format (one that can only be interpreted one way).
DateSerial(2017, 11, 1)
CDate("2017-11-01")
CDate("1 Nov 2017")
I have a code which performs different checks for 3 different columns. It works absolutely fine, but I want some alteration. Let’s see the code first.
Sub test()
On Error Resume Next
Dim cel As Range
Dim colCStr As String, colDStr As String, colEStr As String
Set ws = Sheets("Sheet1")
With ws
LastRow = .Cells(.Rows.count, "C").End(xlUp).row
For Each cel In .Range("C2:C" & LastRow)
'condition for Column C (cell not empty & characters in cell are alphabet)
For i = 1 To Len(cel)
If Not (Not IsEmpty(cel) And Asc(UCase(cel)) > 64 And Asc(UCase(cel)) < 91) Then
colCStr = colCStr & "," & cel.row
Exit For
End If
Next i
'condition for Column D (cell is numeric & length of cell value is 2 or 3)
If Not (IsNumeric(cel.Offset(0, 1)) And (Len(cel.Offset(0, 1)) = 2 Or Len(cel.Offset(0, 1)) = 3)) Then
colDStr = colDStr & "," & cel.Offset(0, 1).row
End If
'condition for Column E (cell is numeric & length of cell value is 7 or 8 or cell value is 0)
If Not (IsNumeric(cel.Offset(0, 2)) And (Len(cel.Offset(0, 2)) = 7 Or Len(cel.Offset(0, 2)) = 8) Or cel.Offset(0, 2) = 0) Then
colEStr = colEStr & "," & cel.Offset(0, 2).row
End If
Next cel
End With
'disply message box only if there's error
If Len(colCStr) > 0 Then
Sheets("Error_sheet").Range("A2" & row).Value = "Errors in Column C" & " : " & Mid(colCStr, 2, Len(colAStr))
If Len(colDStr) > 0 Then
Sheets("Error_sheet").Range("B2" & row).Value = "Errors in Column D" & " : " & Mid(colDStr, 2, Len(colDStr))
If Len(colEStr) > 0 Then
Sheets("Error_sheet").Range("C2" & row).Value = "Errors in Column E" & " : " & Mid(colEStr, 2, Len(colEStr))
Else
End If
End If
End Sub
The code performs following checks:
Column C: Cell not empty & characters in cell are alphabet (Actually I don’t want to perform any checks over here in Column C, but if I delete the lines of code which validate Column C the rest of code stops getting executed too).
Column D: Cell is numeric & length of cell value is 2 or 3 (I want the absolutely same checks).
Column E: Cell is numeric & length of cell value is 7 or 8 or cell value is 0 (I want the absolutely same checks).
I appreciate your time and efforts.
This version doesn't use Offset so it should be easier to update (and more efficient)
Option Explicit
Public Sub CheckColDandE()
Dim ws As Worksheet, lr As Long, arr As Variant, r As Long
Dim dOk As Boolean, eOk As Boolean, dErr As String, eErr As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
arr = ws.Range("D2:E" & lr)
For r = 1 To lr - 1
dOk = IsNumeric(arr(r, 1)) And arr(r, 1) > 9 And arr(r, 1) < 1000
eOk = IsNumeric(arr(r, 2))
eOk = eOk And (arr(r, 2) > 999999 And arr(r, 2) < 100000000 Or arr(r, 2) = 0)
If Not dOk Then dErr = dErr & r + 1 & ", "
If Not eOk Then eErr = eErr & r + 1 & ", "
Next
With ws.Range("D" & lr + 1 & ":E" & lr + 1)
.Value2 = vbNullString
If Len(dErr) > 0 Then .Cells(1) = "Rows with Errors: " & Left(dErr, Len(dErr) - 2)
If Len(eErr) > 0 Then .Cells(2) = "Rows with Errors: " & Left(eErr, Len(eErr) - 2)
End With
End Sub
Delete the following lines (and update your comments! The column names in comments and code ae not the same):
'condition for Column A (cell not empty & characters in cell are alphabet)
For i = 1 To Len(cel)
If Not (Not IsEmpty(cel) And Asc(UCase(cel)) > 64 And Asc(UCase(cel)) < 91) Then
colCStr = colCStr & "," & cel.row
Exit For
End If
Next i
I have value in Sheet1 "B" column which is to be vlookup in Sheet2 from Column "A to K" and copy the corresponding C column value of Sheet2 and paste it in Sheet1's E column.
I have tried with below code but it shows error as
Run-time error '1004':
Unable to get the Vlookup Property of the worksheetfunction class.
Sub vlook_up()
For i = 2 To 11
Cells("D" & i).Value = WorksheetFunction.VLookup(Sheets("Sheet1").Range("B" & i), Sheets("Sheet2").Range("A1:K500"), 3, 0)
Next i
End Sub
This works for me, however I feel you are passing the function an inappropriate var type.
Sub vlook_up()
For i = 2 To 11
Range("D" & i).Value = WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Sheets("Sheet1").Range("B" & i), Sheets("Sheet2").Range("A1:K500"), 3, False), "error")
Next i
End Sub
Try with this
Sub vlook_up()
For i = 2 To 11
Range("D" & i).Value = Application.WorksheetFunction.VLookup(Sheets("Sheet1").Range("B" & i), Sheets("Sheet2").Range("A1:K500"), 3, False);
Next i
End Sub
or
Sub vlook_up()
For i = 2 To 11
Range("D" & i).Value = Application.VLookup(Sheets("Sheet1").Range("B" & i), Sheets("Sheet2").Range("A1:K500"), 3, False);
Next i
End Sub
I am using the following VBA code to change the color of the rows in my spreadsheet every time the value in Column A changes (So that all entries with the same value in column A will be grouped by color. The spreadsheet is sorted by column A already so the items are already grouped, I just needed them colored).
Anyway, when I run this macro the rows are colored red & green (which are very bright and overwhelming colors for this purpose). I need something more subtle..
How do I change this? Or can I specify in my VBA code for it to use certain colors by rgb or color index? {I am using Excel 2007}
Sub colorize()
Dim r As Long, val As Long, c As Long
r = 1
val = ActiveSheet.Cells(r, 1).Value
c = 4
For r = 1 To ActiveSheet.Rows.Count
If IsEmpty(ActiveSheet.Cells(r, 1).Value) Then
Exit For
End If
If ActiveSheet.Cells(r, 1).Value <> val Then
If c = 3 Then
c = 4
Else
c = 3
End If
End If
ActiveSheet.Rows(r).Select
With Selection.Interior
.ColorIndex = c
.Pattern = xlSolid
End With
val = ActiveSheet.Cells(r, 1).Value
Next
End Sub
Run this program (credits here)
Sub colors56()
'57 colors, 0 to 56
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim i As Long
Dim str0 As String, str As String
For i = 0 To 56
Cells(i + 1, 1).Interior.ColorIndex = i
Cells(i + 1, 1).Value = "[Color " & i & "]"
Cells(i + 1, 2).Font.ColorIndex = i
Cells(i + 1, 2).Value = "[Color " & i & "]"
str0 = Right("000000" & Hex(Cells(i + 1, 1).Interior.Color), 6)
'Excel shows nibbles in reverse order so make it as RGB
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
'generating 2 columns in the HTML table
Cells(i + 1, 3) = "#" & str & "#" & str & ""
Cells(i + 1, 4).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
Cells(i + 1, 5).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
Cells(i + 1, 6).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
Cells(i + 1, 7) = "[Color " & i & ")"
Next i
done:
Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic
Application.ScreenUpdating = True
End Sub
Output sample:
You can customize the colors palette by code, I think the page here will answer your question:
http://www.databison.com/index.php/excel-color-palette-and-color-index-change-using-vba/
Sub change_palette_color
dim color_index as long
color_index = 10
ActiveWorkbook.Colors(color_index) = RGB(128, 128, 128)
End sub
It turns out all I had to do is change a few numbers in the code i posted in my question. I bolded the numbers I had to change. These numbers correspond to the color ID (like what Belisarious put). NOTE: I had to put apostrohpes so that the VBA code wouldn't be recognized as VBA code (because if it is it won't bold the numbers). See the original question for the correct code.
Dim r As Long, val As Long, c As Long
'r = 1
'val = ActiveSheet.Cells(r, 1).Value
'c = 4
'For r = 1 To ActiveSheet.Rows.Count
If IsEmpty(ActiveSheet.Cells(r, 1).Value) Then
Exit For
End If
' If ActiveSheet.Cells(r, 1).Value <> val Then
If c = 3 Then
c = 4
Else
c = 3
End If
End If
ActiveSheet.Rows(r).Select
With Selection.Interior
.ColorIndex = c
.Pattern = xlSolid
End With
val = ActiveSheet.Cells(r, 1).Value
Next
End Sub