Related
I need help for a macro code.
In my case the excel macro checks data in one sheet ("Check_file") for completeness and correctness.
There are mandatory columns in the sheet which have to exist and also not-mandatory columns can exist.
In my example the columns “company” and “fee” are mandatory columns, if they are missing or false the macro will throw an error.
Next to them, the column “gross fee” is not-mandatory and its data should only be checked with the data in column “fee”, if column “gross fee” exists. If it exists, the amount should be the same as in column “fee”. If it doesnt exist, there should be no comparison.
The check for the mandatory columns works fine within a For-Loop and an own Range.
My problem is that I dont know how I can involve the not-mandatory columns into the loop of the mandatory columns…
I tried to define a separate Range for the not-mandatory columns area. But it seems that I cannnot create the connection to the not-mandatory column if it is not set in the mandatory columns loop. But if it is set to the mandatory columns range and the not-mandatory column doesnt exist, an error will be thrown.
Should the exist-check for the not-mandatory columns be placed in a separate Sub or Function? If yes, how can the connection be created to the mandatory check Range?
This is the vba code:
Function Main_Check(ByVal StrFilePath As String) As String
'//Checks all criteria for the correct filling of the template. Marks all fields that are incorrectly
filled in red.
Dim WB As Workbook, WS As Worksheet
Dim i As Long, iNotMand As Long, lEnde As Long, strHeader As String, ii As Long, lColEnde As Long
Dim rngFind As Range, booCheck As Boolean, rngHeader As Range, rngKey As Range, rngUsed As Range,
rngHeaderNotMand As Range, rngFindNotMand As Range, rngKeyGrossFee As Range, rngGrossFee As Range
Dim strKey As String, arrKey As String, strKeyGrossFee As String, strGrossFee As String
On Error GoTo ErrorHandler
If StrFilePath = “” Then GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'//Template is opened
Set WB = Workbooks.Open(StrFilePath)
Set WS = WB.Worksheets(“Check_file”)
With WS
.Cells.EntireColumn.AutoFit
'//Stores the last row and column to be processed
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
lColEnde = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
'//Find the beginning of the table
Set rngFind = .Cells.Find(what:=Settings.Cells(Settings.Range("Header_Start").Row + 1, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngFind Is Nothing Then
booCheck = False
End
End If
.Range(rngFind.Address, .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row,
rngFind.Column)).EntireRow.Hidden = False
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
'//booCheck is set to true and on error to false _
Thus, if "True" is passed, the complete file is correct
Set rngUsed = .Range(rngFind.Address, .Cells(lEnde, lColEnde))
booCheck = IsErrorAll(rngUsed)
'//Header Check _
Checks all headers in advance to see if they are present and writes the missing ones in a cell
.Cells(4, 7).Clear
.Cells(4, 8).Clear
For i = Settings.Range("Header_Start").Row + 1 To Settings.Range("Header_Ende").Row - 1
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=Settings.Cells(i, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngHeader Is Nothing Then
booCheck = False
.Cells(4, 7).Value = "The following column labels were not found: "
If .Cells(4, 8).Value = "" Then
.Cells(4, 8).Value = .Cells(4, 8).Value & Settings.Cells(i, 2).Value
Else
.Cells(4, 8).Value = "," & .Cells(4, 8).Value & Settings.Cells(i, 2).Value
End If
.Cells(4, 8).Interior.Color = vbRed
Else
End If
Next i
If booCheck = False Then GoTo Ende
'// Check Not-Mandatory Columns _
Checks in advance whether Not-mandatory columns are available
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
For iNotMand = Settings.Range("NotMand_Start").Row + 1 To Settings.Range("NotMand_Ende").Row - 1
Set rngHeaderNotMand = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=Settings.Cells(iNotMand, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not rngHeaderNotMand Is Nothing Then
'//Not-mandatory columns are defined
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Else
strKeyGrossFee = ""
End If
'//All line items are run through and the individual criteria are checked
For i = rngFind.Row + 1 To lEnde Step 1
'//Company
strKey = "Company"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
iCoi = rngHeader.Column
If .Cells(i, rngHeader.Column).Value Like "####" Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
Else
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
End If
'//Fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngHeader.Column).Value Like "*,*" Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
'//Gross fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Set rngGrossFee = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=strGrossFee, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngGrossFee.Column).Value Is Nothing Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
ElseIf .Cells(i, rngHeader.Column).Value <> .Cells(i, rngGrossFee.Column).Value Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
Next i
End With
'//Define results
Ende:
Main_Check = booCheck & “,” & Replace(CStr(rngFind.Address), “$”, “”)
If booCheck = False Then
WS.Cells(7, 7).Value = “Error counter:”
WS.Cells(7, 8).Value = WS.Cells(7, 8).Value + 1
Else
WS.Cells(7, 7).Value = “Check ok”
WS.Cells(7, 8).Value = “”
End If
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Function
'//If there are other errors, it should exit here and return ERROR
ErrorHandler:
On Error GoTo -1
On Error Resume Next
Main_Check = “ERROR”
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Function
I would recommend you refactor your code into 3 parts. 1- read the settings, 2- profile the sheet and then 3- check the data. Debug each step in turn.
Function Main_Check2(ByVal StrFilePath As String) As String
Const CHECK = "Check_file"
Dim wb As Workbook, ws As Worksheet, arHdr
Dim booCheck As Boolean, bExists As Boolean
Dim iColFee As Long, i As Long, msg As String
' check valid filepath
If Dir(StrFilePath) = "" Then
msg = "'" & StrFilePath & "' does not exist"
MsgBox msg, vbCritical, "File not found"
Main_Check2 = msg
Exit Function
End If
' open file and check sheet exists
Set wb = Workbooks.Open(StrFilePath)
bExists = False
For Each ws In wb.Sheets
If ws.Name = CHECK Then
bExists = True
Exit For
End If
Next
If Not bExists Then
msg = "Sheet '" & CHECK & "' not found in " & wb.FullName
MsgBox msg, vbCritical, "Sheet not found"
wb.Close False
Exit Function
End If
' get header details from settings sheet
Call GetSettings(Settings, arHdr)
' check headers, find fee column
booCheck = CheckHeaders(ws, arHdr, iColFee)
'Call DumpArray(arHdr) ' check results so far
' exit if false
If booCheck = False Then
Main_Check2 = booCheck
Exit Function
End If
' check data
With ws
'//All line items are run through and the individual criteria are checked
Dim rngData As Range, sName As String, n As Long
Dim iRow As Long, iCol As Long, lastrow As Long, cell As Range
For i = 1 To UBound(arHdr)
sName = arHdr(i, 1) ' header name
iCol = arHdr(i, 4) ' header column
iRow = arHdr(i, 5) ' header row
n = arHdr(i, 6) ' number of rows
' scan column
If iCol > 0 And n > 0 Then
Set rngData = .Cells(iRow + 1, iCol).Resize(n)
Select Case sName
Case "Company"
For Each cell In rngData
If cell.Value Like "####" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Fee"
For Each cell In rngData
If Not cell.Value Like "*,*" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Gross Fee"
' optional - skipped if icol = 0
For Each cell In rngData
If Len(cell) = 0 Then
cell.Interior.Pattern = xlNone
ElseIf cell.Value <> .Cells(cell.Row, iColFee).Value Then
cell.Interior.Color = vbRed
booCheck = False
Else
cell.Interior.Pattern = xlNone
End If
Next
End Select
End If
Next
End With
'//Define results
Ende:
If booCheck = False Then
ws.Cells(7, 7).Value = "Error counter:"
ws.Cells(7, 8).Value = ws.Cells(7, 8).Value + 1
Else
ws.Cells(7, 7).Value = "Check ok"""
ws.Cells(7, 8).Value = ""
End If
'wb.Close True
Main_Check2 = booCheck '& "," & Replace(CStr(rngFind.Address), "$", "")
End Function
Function GetSettings(ws, ByRef arHdr) As Boolean
Dim r1 As Long, r2 As Long, r3 As Long, r4 As Long
Dim n As Long, m As Long, i As Long, msg As String
With ws
r1 = .Range("Header_Start").Row
r2 = .Range("Header_Ende").Row
r3 = .Range("NotMand_Start").Row
r4 = .Range("NotMand_Ende").Row
m = r2 - r1 - 1 ' mandatory header
n = r4 - r3 - 1 ' non-mandatory headers
If m < 1 Then
msg = "No mandatory headers on setting"
MsgBox msg, vbExclamation, "Settings Error"
getSettings = False
End If
' size array and fill
ReDim arHdr(1 To n + m, 1 To 6)
For i = 1 To m
arHdr(i, 1) = .Cells(r1 + i, 1)
arHdr(i, 2) = .Cells(r1 + i, 2) ' search term
If Len(arHdr(i, 2)) > 0 Then ' skip blanks
arHdr(i, 3) = True ' mandatory
Else
arHdr(i, 3) = False
End If
Next
For i = 1 To n
arHdr(m + i, 1) = .Cells(r3 + i, 1)
arHdr(m + i, 2) = .Cells(r3 + i, 2)
arHdr(m + i, 3) = False ' optional
Next
End With
getSettings = True
End Function
Function CheckHeaders(ws, ByRef arHdr, ByRef iColFee) As Boolean
'//Header Check
'Checks all headers in advance to see if they are present
'and writes the missing ones in a cell
Dim rngTable As Range, rng As Range
Dim msg As String, sHdr As String, sTableStart As String
Dim i As Long, lastrow As Long, rowHdr As Long
Dim booCheck As Boolean
' search value for column 1 of table
sTableStart = arHdr(1, 2)
With ws
'//Find the beginning of the table
Set rngTable = .Cells.Find(what:=sTableStart, LookIn:=xlValues, lookat:=xlWhole)
If rngTable Is Nothing Then
msg = "Could not find begining of table '" & sTableStart & "'"
MsgBox msg, vbExclamation, "Error"
CheckHeaders = False
Exit Function
Else
rowHdr = rngTable.Row
End If
For i = 1 To UBound(arHdr)
sHdr = Trim(arHdr(i, 2))
If Len(sHdr) > 0 Then ' skip blanks
Set rng = .Rows(rowHdr).Find(what:=sHdr, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
arHdr(i, 4) = 0
Else
' store fee column for later gross fee check
If arHdr(i, 1) = "Fee" Then iColFee = rng.Column
arHdr(i, 4) = rng.Column
arHdr(i, 5) = rng.Row
lastrow = .Cells(.Rows.Count, rng.Column).End(xlUp).Row
arHdr(i, 6) = lastrow - rng.Row - 1 ' data rows
End If
Else
arHdr(i, 4) = 0
End If
Next
' check for mandatory column errors
Dim sep As String
For i = 1 To UBound(arHdr)
If arHdr(i, 3) And arHdr(i, 4) = 0 Then
msg = msg & sep & arHdr(i, 2)
sep = ","
End If
Next
If Len(msg) > 0 Then
.Cells(4, 7) = "The following column labels were not found: "
.Cells(4, 8) = msg
.Cells(4, 8).Interior.Color = vbRed
CheckHeaders = False
'GoTo Ende
Else
.Cells(4, 7).Clear ' G4
.Cells(4, 8).Clear ' H4
CheckHeaders = True
End If
End With
End Function
' dump array to new workbook to debug
Sub DumpArray(ar)
Dim wb As Workbook: Set wb = Workbooks.Add
With wb.Sheets(1)
.Name = "arHdr"
.Range("A1:F1") = Array("Header1", "Header2", "Mandatory", "Column", "Row", "DataRows")
.Range("A2").Resize(UBound(ar), UBound(ar, 2)) = ar
End With
' save - replace existing
Application.DisplayAlerts = False
wb.SaveAs "debug_arHdr.xlsx"
Application.DisplayAlerts = True
'wb.Close
End Sub
I want to add cell value from one table to another. the first table contains about 110 000 rows (tabCDL) and the other about 37 000 rows (tabEMP). It takes about one hour to do right now and I need to do it faster.
Public Sub MergeColumnEMP()
'Merge
Dim cel, cel2, rngCDL, rngEMP As Range
Dim shtCDL, shtEMP As Worksheet
Dim LastRowCDL, LastRowEMP As Long
Set shtCDL = Sheets("CEDULE")
Set shtEMP = Sheets("EMPRUNT")
LastRowCDL = shtCDL.ListObjects("TabCEDULE").Range.Rows.Count
LastRowEMP = shtEMP.ListObjects("TabEMP").Range.Rows.Count
Set rngCDL = Sheets("CEDULE").Range("H2:H" & LastRowCDL)
Set rngEMP = Sheets("EMPRUNT").Range("C2:C" & LastRowEMP)
For Each cel In rngCDL
For Each cel2 In rngEMP
If cel.Value = cel2.Value Then
'amount
Sheets("CEDULE").Range("I" & cel.Row).Value = Sheets("EMPRUNT").Range("D" & cel2.Row).Value
'Date dstart
Sheets("CEDULE").Range("J" & cel.Row).Value = Sheets("EMPRUNT").Range("H" & cel2.Row).Value
'Date end
Sheets("CEDULE").Range("K" & cel.Row).Value = Sheets("EMPRUNT").Range("I" & cel2.Row).Value
Exit For
End If
Next cel2
Next cel
Debug.Print "DONE merging"
End Sub
Try the next way, please. It uses arrays and should be very fast. Not tested, but it should work, if I did not messed anything up regarding the involved ranges:
Sub MergeColumnEMP() 'unique in EMP, not unique in CEDULE
Dim arrCDL, arrEMP, rngCopy As Range, i As Long, j As Long
Dim shtCDL As Worksheet, shtEMP As Worksheet
Dim LastRowCDL As Long, LastRowEMP As Long
Set shtCDL = Sheets("CEDULE")
Set shtEMP = Sheets("EMPRUNT")
LastRowCDL = shtCDL.ListObjects("TabCEDULE").Range.rows.Count
LastRowEMP = shtEMP.ListObjects("TabEMP").Range.rows.Count
arrCDL = shtCDL.Range("H2:K" & LastRowCDL).value 'h
arrEMP = Sheets("EMPRUNT").Range("C2:I" & LastRowEMP).value 'c
For i = 1 To UBound(arrCDL)
For j = 1 To UBound(arrEMP)
If arrCDL(i, 1) = arrEMP(j, 1) Then
arrCDL(i, 2) = arrEMP(j, 2)
arrCDL(i, 3) = arrEMP(j, 5)
arrCDL(i, 4) = arrEMP(j, 6)
Exit For
End If
Next j
Next i
shtCDL.Range("H2").Resize(UBound(arrCDL), UBound(arrCDL, 2)).value = arrCDL
MsgBox "DONE merging"
End Sub
Edited:
Please, also test the next code, which should be faster:
Sub MergeColumnEMPLast() 'unique in EMP, not unique in CEDULE
Dim arrCDL, arrEMP, rngCopy As Range, i As Long, j As Long
Dim shtCDL As Worksheet, shtEMP As Worksheet
Dim LastRowCDL As Long, LastRowEMP As Long
Dim dict As New Scripting.Dictionary, iMatch As Variant
Set shtCDL = Sheets("CEDULE")
Set shtEMP = Sheets("EMPRUNT")
LastRowCDL = shtCDL.ListObjects("TabCEDULE").Range.rows.Count
LastRowEMP = shtEMP.ListObjects("TabEMP").Range.rows.Count
arrCDL = shtCDL.Range("H2:K" & LastRowCDL).value 'h
arrEMP = shtEMP.Range("C2:I" & LastRowEMP).value 'c
For i = 1 To UBound(arrCDL)
If dict.Count > 0 Then iMatch = Application.match(arrCDL(i, 1), dict.Keys, 0)
If Not IsError(iMatch) Then
If dict.Count > 0 Then
If iMatch <> dict.Count Or (iMatch = dict.Count And arrCDL(i, 1) = dict.Keys(dict.Count - 1)) Then
arrCDL(i, 2) = dict.items(iMatch - 1)(0)
arrCDL(i, 3) = dict.items(iMatch - 1)(1)
arrCDL(i, 4) = dict.items(iMatch - 1)(2)
GoTo OverIteration
End If
End If
End If
For j = 1 To UBound(arrEMP)
If arrCDL(i, 1) = arrEMP(j, 1) Then
arrCDL(i, 2) = arrEMP(j, 2)
arrCDL(i, 3) = arrEMP(j, 6)
arrCDL(i, 4) = arrEMP(j, 7)
dict.Add arrCDL(i, 1), Array(arrEMP(j, 2), arrEMP(j, 6), arrEMP(j, 7))
Exit For
End If
Next j
OverIteration:
Next i
shtCDL.Range("H2").Resize(UBound(arrCDL), UBound(arrCDL, 2)).value = arrCDL
MsgBox "DONE merging"
End Sub
I am just curious how much it takes for your range...
With a Dictionary Object as a look-up
Option Explicit
Public Sub MergeColumnEMP()
'Merge
Dim wb As Workbook
Dim shtCDL As Worksheet, shtEMP As Worksheet
Dim cel As Range, rngCDL, rngEMP As Range
Dim LastRowCDL As Long, LastRowEMP As Long, t0 As Single
t0 = Timer
Set wb = ThisWorkbook
Set shtCDL = wb.Sheets("CEDULE")
LastRowCDL = shtCDL.ListObjects("TabCEDULE").Range.Rows.Count
Set rngCDL = shtCDL.Range("H2:H" & LastRowCDL)
Set shtEMP = wb.Sheets("EMPRUNT")
LastRowEMP = shtEMP.ListObjects("TabEMP").Range.Rows.Count
Set rngEMP = shtEMP.Range("C2:C" & LastRowEMP)
Dim dict As Object, key As String, r As Long
Set dict = CreateObject("Scripting.Dictionary")
' fill dictionary with rowno as value
For Each cel In rngEMP
key = Trim(cel)
If Len(key) > 0 Then dict(key) = cel.Row
Next
' compare using dictionary
For Each cel In rngCDL ' col H
key = Trim(cel)
If Len(key) > 0 And dict.exists(key) Then
r = dict(key)
With shtCDL
' update
cel.Offset(0, 1) = shtEMP.Range("D" & r).Value ' I amount
cel.Offset(0, 2) = shtEMP.Range("H" & r).Value ' J Date dstart
cel.Offset(0, 3) = shtEMP.Range("I" & r).Value ' K Date end
End With
End If
Next
MsgBox "DONE merging", vbInformation, "Duration " & Int(Timer - t0) & " seconds"
End Sub
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
I have a macro that threw the below error, and I have a theory why, but am having trouble finding any literature to back it up. Pages I found are typically people posting silly mistakes with incorrect variable types.
I don't think there's anything wrong with the code, I just think the nature of the task takes too long, therefore overloading the temp folder. Per TechWalla (emphasis mine):
The Runtime Error 6 occurs in the Visual Basic program. It is an overflow issue that can occur when the Visual Basic program attempts to store too much data in the temporary folders area. Runtime files help Windows translate a program's language into Windows language so the program runs faster. You can get the Runtime Error 6 message for several reasons. One reason is that you are using a backslash instead of a forward slash in one of your calculations. Other reasons include an overloaded temporary folder, outdated software or a registry error.
(Caveat: I haven't seen this explanation elsewhere and can't vouch for how reliable Techwalla is. I don't know if I'm not searching with the right keywords, but like I said, I haven't found much of anything other than code-specific forum posts.)
Is there a way to determine if this is the case? I outline below why I think this is what's causing the error, which might help, but doesn't change the question. If this is the case, is there a way to find out? And if so, is there a way to prevent it?
(I'll be running it again tonight now that I've used a registry cleaner that found 1GB, though I don't know how much was from Excel. For reference, my C: drive has 180GB free...)
EDIT: Removing code, because I'm asking not asking about that, but whether or not the temporary folder overloading could actually cause this.
EDIT2: After being swayed by the people, I am re-adding the code. And I know, it's not efficient. Thank you for the suggestions though.
EDIT3 (LAST ONE, I SWEAR): Though I realize the description above specifically mentions Visual Basic, which is not VBA, I'm keeping it in as I know Excel uses/creates temporary files, and has memory limits, which is ultimately what I'm curious about.
Sub getCBU()
Dim rowCount As Long, newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant, nextFile As String, s As Long
Dim location As String, lastRow As Long, match As Boolean, startTime As Double, secondsElapsed As String
location = "C:\Users\swallin\Documents\CBU History\"
nextFile = Dir(location & "CBU*")
rowCount = 2
startTime = Timer
Do While nextFile <> ""
Workbooks.Open (location & nextFile)
lastRow = Workbooks(nextFile).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For s = 18 To lastRow
match = True
For x = 1 To 17
newRow(x) = Workbooks(nextFile).Worksheets(1).Cells(s, x)
Next x
For y = 2 To rowCount
If Val(newRow(11)) = Val(ThisWorkbook.Worksheets(1).Cells(y, 11)) Then
For j = 1 To 17
compareRow(j) = ThisWorkbook.Worksheets(1).Cells(y, j).Value
Next j
For v = 1 To 17
If Val(compareRow(v)) <> Val(newRow(v)) Then
match = False
Exit For
Else
match = True
End If
Next v
If match = True Then
Exit For
End If
Else
match = False
End If
Next y
y = 2
If match = False Then
rowCount = rowCount + 1
For t = 1 To 17
ThisWorkbook.Worksheets(1).Cells(rowCount, t) = newRow(t)
Next t
End If
Next s
s = 18
Workbooks(nextFile).Close
nextFile = Dir()
Loop
secondsElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed
End Sub
This opens a new instance for each file and closes it afterwards. Give it a try (I could not test it). This includes all the suggestions I made in the chat.
Option Explicit
Sub getCBU()
Dim location As String
location = "C:\Users\swallin\Documents\CBU History\"
Dim nextFile As String
nextFile = Dir(location & "CBU*")
Dim rowCount As Long
rowCount = 2
Dim startTime As Double
startTime = Timer
Dim newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant
Dim lastRow As Long, match As Boolean
Dim s As Long, x As Long, y As Long, j As Long, v As Long, t As Long
Dim objExcel As Object, ActWb As Workbook
Do While nextFile <> ""
Set objExcel = CreateObject("Excel.Application") 'new excel instance
Set ActWb = objExcel.Workbooks.Open(Filename:=location & nextFile, ReadOnly:=True)
lastRow = ActWb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For s = 18 To lastRow
match = True
For x = 1 To 17
newRow(x) = ActWb.Worksheets(1).Cells(s, x)
Next x
For y = 2 To rowCount
If Val(newRow(11)) = Val(ThisWorkbook.Worksheets(1).Cells(y, 11)) Then
For j = 1 To 17
compareRow(j) = ThisWorkbook.Worksheets(1).Cells(y, j).Value
Next j
For v = 1 To 17
If Val(compareRow(v)) <> Val(newRow(v)) Then
match = False
Exit For
Else
match = True
End If
Next v
If match = True Then
Exit For
End If
Else
match = False
End If
Next y
y = 2
If match = False Then
rowCount = rowCount + 1
For t = 1 To 17
ThisWorkbook.Worksheets(1).Cells(rowCount, t) = newRow(t)
Next t
End If
Next s
s = 18
ActWb.Close SaveChanges:=False
objExcel.Quit 'close excel instance
Set objExcel = Nothing 'free variable
nextFile = Dir()
Loop
Dim secondsElapsed As String
secondsElapsed = Format$((Timer - startTime) / 86400, "hh:mm:ss")
ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed
End Sub
Not sure about the writing back to the sheet part (i would still allocate the values to an array and write it back all together, but that depends on what you have in the sheet already, plus whatever newRow() does), but can you give this a try and see if there is any improvement in speed?
Sub getCBU()
Dim rowCount As Long, newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant, nextFile As String
Dim location As String, lastRow As Long, match As Boolean, startTime As Double, secondsElapsed As String
Dim arrData, arrOutput()
Dim arrTemp(): ReDim arrOutput(1 To 17, 1 To 1)
Dim R As Long, C As Long
location = "C:\Users\swallin\Documents\CBU History\"
nextFile = Dir(location & "CBU*")
rowCount = 2
startTime = Timer
Do While nextFile <> ""
Workbooks.Open (location & nextFile)
lastRow = Workbooks(nextFile).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
With Workbooks(nextFile).Worksheets(1)
arrData = .Range(.Cells(1, 1), .Cells(lastRow, 17))
End With
For s = 18 To lastRow
match = True
For X = 1 To 17
newRow(X) = arrData(s, X)
Next X
For y = 2 To rowCount
If Val(newRow(11)) = Val(arrData(y, 11)) Then
For j = 1 To 17
compareRow(j) = arrData(y, j).Value
Next j
For v = 1 To 17
If Val(compareRow(v)) <> Val(newRow(v)) Then
match = False
Exit For
Else
match = True
End If
Next v
If match = True Then
Exit For
End If
Else
match = False
End If
Next y
y = 2
If match = False Then
rowCount = rowCount + 1
ReDim Preserve arrTemp(1 To 17, 1 To rowCount)
For t = 1 To 17
arrTemp(t, rowCount) = newRow(t)
Next t
End If
Next s
s = 18
Workbooks(nextFile).Close
nextFile = Dir()
Loop
'Transpose the array
ReDim arrOutput(1 To UBound(arrTemp, 2), 1 To UBound(arrTemp))
For C = LBound(arrTemp) To UBound(arrTemp)
For R = LBound(arrTemp, 2) To UBound(arrTemp, 2)
arrOutput(R, C) = arrTemp(C, R)
Next R
Next C
'Allocate back to the spreadsheet
With ThisWorkbook.Worksheets(1)
.Range(.Cells(2, 1), .Cells(UBound(arrOutput) + 1, 17)) = arrOutput
End With
secondsElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed
End Sub
PS: As others suggested, is a good idea to use Option Explicit, and eventually to step through to code and see if everything is working as intended.
As for the Overflow issue... stepping through code would/should resolve that as well eventually. See Overflow (Error 6) for more info.
EDIT: I've added further management to holding the values in an array, and writing back to the spreadsheet.
Here's a revamp of your code that should be quicker and more memory friendly. (updated to be able to handle any number of results).
Sub getCBU()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsTime As Worksheet
Dim hUnqVals As Object
Dim hUnqRows As Object
Dim aHeaders() As Variant
Dim aCompare() As Variant
Dim aResults() As Variant
Dim aStartingData() As Variant
Dim sFolder As String
Dim sFile As String
Dim sDelim As String
Dim sTemp As String
Dim lMaxResults As Long
Dim lCompareStartRow As Long
Dim lValCompareCol As Long
Dim ixCompare As Long
Dim ixResult As Long
Dim ixCol As Long
Dim dTimer As Double
dTimer = Timer
Set wb = ThisWorkbook
Set wsDest = wb.Worksheets(1)
Set wsTime = wb.Worksheets(2)
Set hUnqRows = CreateObject("Scripting.Dictionary")
Set hUnqVals = CreateObject("Scripting.Dictionary")
sDelim = "|"
lMaxResults = 100000
lCompareStartRow = 18
lValCompareCol = 11
sFolder = Environ("UserProfile") & "\Documents\CBU History\" 'Be sure to including ending \
sFile = Dir(sFolder & "CBU*.xlsx")
With wsDest.Range("A2:Q" & wsDest.Cells(wsDest.Rows.Count, lValCompareCol).End(xlUp).Row)
If .Row > 1 Then
aHeaders = .Offset(-1).Resize(1).Value
aStartingData = .Value
ReDim aResults(1 To lMaxResults, 1 To .Columns.Count)
For ixResult = 1 To UBound(aStartingData, 1)
For ixCol = 1 To UBound(aStartingData, 2)
sTemp = sTemp & sDelim & aStartingData(ixResult, ixCol)
Next ixCol
If Not hUnqRows.Exists(sTemp) Then hUnqRows.Add sTemp, sTemp
If Not hUnqVals.Exists(aStartingData(ixResult, lValCompareCol)) Then hUnqVals.Add aStartingData(ixResult, lValCompareCol), aStartingData(ixResult, lValCompareCol)
sTemp = vbNullString
Next ixResult
Erase aStartingData
Else
'No data to compare against, so no data can be added, exit macro
MsgBox "No data found in [" & wsDest.Name & "]" & Chr(10) & "Exiting Macro.", , "Error"
Exit Sub
End If
End With
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
ixResult = 0
Do While Len(sFile) > 0
Application.StatusBar = "Processing " & sFile & "..."
With Workbooks.Open(sFolder & sFile, , True).Worksheets(1)
With .Range("A" & lCompareStartRow & ":Q" & .Cells(.Rows.Count, lValCompareCol).End(xlUp).Row)
If .Row >= lCompareStartRow Then
aCompare = .Value
For ixCompare = 1 To UBound(aCompare, 1)
If hUnqVals.Exists(aCompare(ixCompare, lValCompareCol)) Then
For ixCol = 1 To UBound(aCompare, 2)
sTemp = sTemp & sDelim & aCompare(ixCompare, ixCol)
Next ixCol
If Not hUnqRows.Exists(sTemp) Then
hUnqRows.Add sTemp, sTemp
ixResult = ixResult + 1
For ixCol = 1 To UBound(aCompare, 2)
aResults(ixResult, ixCol) = aCompare(ixCompare, ixCol)
Next ixCol
If ixResult = lMaxResults Then OutputResults wsDest, aResults, ixResult, aHeaders
End If
sTemp = vbNullString
End If
Next ixCompare
Erase aCompare
End If
End With
.Parent.Close False
End With
sFile = Dir()
Loop
Application.StatusBar = vbNullString
If ixResult > 0 Then OutputResults wsDest, aResults, ixResult, aHeaders
wsTime.Range("A1").Value = Format((Timer - dTimer) / 86400, "hh:mm:ss")
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub OutputResults(ByRef arg_ws As Worksheet, ByRef arg_aResults As Variant, ByRef arg_ixResult As Long, ByVal arg_aHeaders As Variant)
Static wsDest As Worksheet
Dim rDest As Range
Dim lMaxRows As Long
Dim lMaxCols As Long
If wsDest Is Nothing Then Set wsDest = arg_ws
lMaxRows = UBound(arg_aResults, 1)
lMaxCols = UBound(arg_aResults, 2)
Set rDest = wsDest.Range("A1").Resize(, lMaxCols).EntireColumn.Find("*", wsDest.Range("A1"), xlValues, xlWhole, , xlPrevious)
If rDest Is Nothing Then Set rDest = wsDest.Range("A2") Else Set rDest = wsDest.Cells(rDest.Row, "A")
If rDest.Row + 1 + arg_ixResult > wsDest.Rows.Count Then
Set wsDest = wsDest.Parent.Worksheets.Add(After:=wsDest)
With wsDest.Range("A1").Resize(, lMaxCols)
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = wsDest.Range("A2")
End If
rDest.Resize(arg_ixResult, lMaxCols).Value = arg_aResults
Erase arg_aResults
ReDim arg_aResults(1 To lMaxRows, 1 To lMaxCols)
End Sub
My dataset is like this
I want to make them
Please look at the first row.
My code is
Private Sub CommandButton1_Click()
Dim MyColInstance, i As Long
Dim MyWorksheetLastColumn As Byte
MyWorksheetLastColumn = Worksheets(1).Cells(1, columns.Count).End(xlToLeft).Column
For i = 1 To MyWorksheetLastColumn
MyColInstance = ColInstance("Preference", i)
Cells(1, MyColInstance).Value = "Preference" & i
Next i
End Sub
Function ColInstance(HeadingString As String, InstanceNum As Long)
Dim ColNum As Long
On Error Resume Next
ColNum = 0
For X = 1 To InstanceNum
ColNum = (Range("A1").Offset(0, ColNum).Column) + Application.WorksheetFunction.Match(HeadingString, Range("A1").Offset(0, ColNum + 1).Resize(1, Columns.Count - (ColNum + 1)), 0)
Next
ColInstance = ColNum
End Function
The problem is while running this code, it shows an error because the for loop is not complete. What can we do?
Can you do it this way? It seems to me you are just adding a suffix to your headers in the first row...
Sub UpdateColumnHeaders()
Dim headers As Range, header As Range, suffixes As Range, suffix As Range, i As Integer
Set headers = Range(Cells(1, 1), Cells(1, Range("A1").End(xlToRight).Column))
Set suffixes = Range("A1:A" & Range("A1").End(xlDown).Row)
i = 1
For Each header In headers
If header = "Preferences" Then
header = header & suffixes(i)
i = i + 1
End If
Next
End Sub
Private Sub CommandButton1_Click()
Dim Count1, Count2 As Integer
Dim MyWorksheetLastRow As Byte
Dim MyColInstance, emp_i As Long
For Each Row_Cel In Range("1:1")
If Row_Cel.Value = "Employment" Then
Count1 = Count1 + 1
End If
If Row_Cel.Value = "Job" Then
Count2 = Count2 + 1
End If
Next Row_Cel
For emp_i = 1 To Count1
MyColInstance = ColInstance("Employment", emp_i)
Cells(1, MyColInstance).Value = "Employment" & emp_i
Next emp_i
For emp_i = 1 To Count2
MyColInstance = ColInstance("Job", emp_i)
Cells(1, MyColInstance).Value = "Job" & emp_i
Next emp_i
End Sub
Function ColInstance(HeadingString As String, InstanceNum As Long)
Dim ColNum As Long
On Error Resume Next
ColNum = 0
For X = 1 To InstanceNum
ColNum = (Range("A1").Offset(0, ColNum).Column) + Application.WorksheetFunction.Match(HeadingString, Range("A1").Offset(0, ColNum + 1).Resize(1, Columns.Count - (ColNum + 1)), 0)
Next
ColInstance = ColNum
End Function