Related
I am trying to do a vlookup using vba to look up each country per continent and return a true value on each column. For example, I get a true under Europe Lookup if Belgium is listed as one of the countries. See below for the current code I have. Issues I want to fix are:
First, I want to be able to lookup each country to confirm if they are in the countries tab. That way, I know if there is a new country I need to add. What I have currently looks up to check if at least one of the countries is listed but would like to make sure all countries are listed.
Additionally, I want to make it automated such that if a new country is added to the countries list, I don't have to edit the macros.
Also, is there a way to do the lookup for separate continents one at a time? Currently, it just returns a true if the country is in the list irrespective of the continents. I know this means I'll have separate lines of codes for each continent but that's fine.
Sub Macro1()
Sheets("Sales Table").Select
Range("D2").Select
Dim LastRowColumnD As Long
LastRowColumnD = Cells(Rows.Count, 1).End(xlUp).Row
Range("D2:D" & LastRowColumnD).Formula = "=SUMPRODUCT(--ISNUMBER(SEARCH('Countries'!R2C1:R11C1,RC[-2])))>0"
Range("E2").Select
Dim LastRowColumnE As Long
LastRowColumnE = Cells(Rows.Count, 1).End(xlUp).Row
Range("E2:E" & LastRowColumnE).Formula = "=SUMPRODUCT(--ISNUMBER(SEARCH('Countries'!R2C1:R11C1,RC[-3])))>0"
End Sub
Not sure what kind of output are you trying to get, but something like this may work for you and you'll need to adapt a little:
Sub test()
Dim i As Long, j As Long, k As Long
Dim LR As Long
Dim Mydata As Variant
Dim WKData As Worksheet
Dim rngCountries As Range
Dim MyF As WorksheetFunction
Set MyF = WorksheetFunction
With ThisWorkbook.Worksheets("Countries")
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rngCountries = .Range("A2:B" & LR)
End With
Set WKData = ThisWorkbook.Worksheets("Sales Table")
With WKData
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Mydata = .Range("B2:B" & LR).Value
For i = 1 To UBound(Mydata) Step 1
j = UBound(Split(Mydata(i, 1), ", "))
'j = how many countries -1, so j+1= total countries in cell
For k = 0 To j Step 1
'we loop trough each country in cell
If MyF.CountIfs(rngCountries.Columns(1), Split(Mydata(i, 1), ", ")(k), rngCountries.Columns(2), "Europe") <> 0 Then .Range("E" & (i + 1)).Value = .Range("E" & (i + 1)).Value + 1 'Europe Check
If MyF.CountIfs(rngCountries.Columns(1), Split(Mydata(i, 1), ", ")(k), rngCountries.Columns(2), "Africa") <> 0 Then .Range("F" & (i + 1)).Value = .Range("F" & (i + 1)).Value + 1 'Africa Check
If MyF.CountIfs(rngCountries.Columns(1), Split(Mydata(i, 1), ", ")(k), rngCountries.Columns(2), "Asia") <> 0 Then .Range("G" & (i + 1)).Value = .Range("G" & (i + 1)).Value + 1 'Asia Check
Next k
'check all countries: if the sum equals k+1, then all countries in cell are present
.Range("D" & (i + 1)).Value = IIf(MyF.Sum(Range("E" & (i + 1) & ":G" & (i + 1))) = k, "YES", "NO")
Next i
End With
'clean variables
Erase Mydata
Set MyF = Nothing
Set rngCountries = Nothing
Set WKData = Nothing
End Sub
I've used arrays and Splits to create arrays so you can loop trough each individual country:
Notice I added "Portugal" to check the "NO" value in the "All countries" column. Every NO means there is a country in that cell that is not present in your range of countries.
The CurrentRegion property of Range will catch countries added to the Countries tab.
You don't necessarily need a separate line of code for each continent. If you keep a consistent column naming strategy, you can make the code flexible enough to catch added continents.
Sub macroSplitter()
Dim wb As Workbook
Dim salesSheet As Worksheet, Countries As Worksheet, continent As String
Dim j As Long
Set wb = ThisWorkbook
Set salesSheet = wb.Worksheets("Sales Table")
Set Countries = wb.Worksheets("Countries")
'Range.CurrentRegion selects a region contiguous with the designated cell
countryArray = Countries.Range("A2").CurrentRegion.Value2
For Each cell In salesSheet.Range("B2", salesSheet.Range("B2").End(xlDown))
splitCell = Split(cell, ", ")
For Each country In splitCell
If inCountry(country, countryArray) Then
continent = whichcontinent(country, countryArray)
'using match to look for continent column, and End(xlToRight) to allow for additional continents to be added
Cells(cell.Row, WorksheetFunction.Match(continent & " Lookup", salesSheet.Range("A1", salesSheet.Range("A1").End(xlToRight)), 0)).Value2 = True
Else
cell.Offset(0, 2).Value2 = False
End If
Next
If cell.Offset(0, 2).Value2 = vbNullString Then cell.Offset(0, 2).Value2 = True
For j = WorksheetFunction.Match("Europe Lookup", salesSheet.Range("A1", salesSheet.Range("A1").End(xlToRight)), 0) To salesSheet.Range("A1").End(xlToRight).Column
If Cells(cell.Row, j).Value2 = vbNullString Then Cells(cell.Row, j).Value2 = False
Next
Next cell
End Sub
Private Function inCountry(c, arr) As Boolean
Dim i As Long
For i = 2 To UBound(arr, 1)
If c = arr(i, 1) Then inCountry = True
Next
End Function
Private Function whichcontinent(c, arr) As String
Dim i As Long
For i = 2 To UBound(arr, 1)
If c = arr(i, 1) Then whichcontinent = arr(i, 2)
Next
End Function
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
My code filters out blanks and 0 records but my array is getting all values.
How can I just take into account the records filtered? Is this the best way I can do this?
Sub FilterAndCopy()
Dim LastRow As Long
Dim Arr As Variant
With Worksheets("BusinessDetails")
.Range("$A5:$AJ5").AutoFilter field:=33, Criteria1:="<>", Criteria2:="<>0", Criteria2:="<>-0"
LastRow = .Range("AG" & .Rows.Count).End(xlUp).Row
Arr = Range("AG8:AG" & LastRow)
Dim R As Long
Dim C As Long
For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
Debug.Print Arr(R, C)
Next C
Next R
Dim Destination As Range
Set Destination = Sheets(2).Range("D10")
Set Destination = Destination.Resize(UBound(Arr), 1)
Destination.Value = Application.Transpose(Arr)
Sheets(1).ShowAllData
End With
End Sub
Updated code:
Sub FilterAndCopy()
Dim LastRow As Long
Dim Arr As Variant
With Worksheets("BusinessDetails")
.Range("$A5:$AJ5").AutoFilter field:=33, Criteria1:="<>", Criteria2:="<>0", Criteria2:="<>-0"
LastRow = .Range("AG" & .Rows.Count).End(xlUp).Row
Set rFiltered = Range("A5:AJ" & LastRow).SpecialCells(xlCellTypeVisible)
ReDim Arr(1 To rFiltered.Areas.Count)
I = 0
For Each V In rFiltered.Areas
I = I + 1
Arr(I) = V
Next V
rFiltered.Copy Sheets("Step 4").Range("D10")
End With
End Sub
When you filter a range, you are left with different Areas.
So your choices are to read one cell at a time into the array, or one area at a time, as an array, into the Parent array.
For example, (data is in A1:C9 and the filtering is done on column A)
With Worksheets("Sheet1")
.Range("$A1:$C9").AutoFilter field:=1, Criteria1:="<>", Criteria2:="<>0"
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rFiltered = Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible)
ReDim Arr(1 To rFiltered.Areas.Count)
I = 0
For Each V In rFiltered.Areas
I = I + 1
Arr(I) = V
Next V
Arr will now be an array of arrays, containing only the filtered cells.
Note
If all you want to do is copy the filtered range, then:
rFiltered.Copy Sheets("sheet2").Range("D10")
Note2
If you are always going to copy, you could then put that data into the array with something like (not tested):
arr = Sheets("sheet2").Range("D10").CurrentRegion
A possibility without the use of AutoFilter and looping:
(when you want to do more then only copying your filtered range)
Sub FilterAndCopyWithoutAutoFilter()
Dim rng As Range, adr As String, Fir As Long, y As Variant
With Worksheets("BusinessDetails")
Set rng = .Range("AG8:AG" & .Range("AG" & .Rows.Count).End(xlUp).Row)
adr = .Name & "!" & rng.Address
Fir = 7 'one less of first row number of your range
With Application
y = .Index(rng, .Transpose(Filter(.Transpose(.Evaluate("if(isnontext(" & adr & "),if(--" & adr & "<>0, row(" & adr & ")-" & Fir & ", ""##"" ),""##"")")), "##", False)), 1)
'or shorter when you want to include text values as well
'y = .Index(rng, .Transpose(Filter(.Transpose(.Evaluate("if(" _
& adr & "<>0, row(" & adr & ")-" & Fir & ", ""##"" )")), "##", False)), 1)
End With
End With
Sheets(2).Range("D10").Resize(UBound(y)).Value = y
End Sub
I am using a macro to re-organise 4600 lines of data into a more efficient layout. Currently, i have a macro but it misses data or puts data in the wrong place.
From the old data, the column A is notification number, column FO is sheet number and GB is zone number. Whilst column C is the data that is wanting to be inputted. So currently (as the photo shows, the data is very unorganisedand unreadable.
In the outputted sheet, the notification number is put in Row 1 in columns F on wards (No duplicates). In Column B and C is zone and sheet number respectively (No duplicates). Then, using the old data, plot Column C values in the correct column(Depending on notification number) and the correct row (depending on zone and sheet number).
I have achieved half of this, but not all values are not be inputted correctly.
I currently use range.find to see if the zone number exists, and if it doesn't add the zone value and sheet number into the last used row. However, if the zone number is found but the corresponding sheet number is different, then add these values and then also add the values from column C. However, if the correct cell is filled, find the next available cell in column that is empty and input value.
But, I cant find a better way to check these values than using range.find but i feel it is missing values and not comparing both values correctly.
Sub GenerateTable()
Application.ScreenUpdating = False
Dim RawDataWsNotificationRng, ModifiedDataWsNotificationRng As Variant
Dim cell As Range
Dim RawDataWsNotificationlrow, ModifiedDataWsNotificationlcolnum, ModifiedDataWsZoneLrow As Long
Dim ModifiedDataWsNotificationlcol As String
Dim serverfilename, DataSheetName, Newsheetname As String
Dim wkbk1, wkbk2 As Workbook
Dim RawDataWs, ModifiedDataWs As Worksheet
Dim FindNotificationNumber As Variant
serverfilename = InputBox("Please input name of dummy workbook (file must be open, include .xlsx")
If serverfilename = "" Then Exit Sub
Set wb1 = ThisWorkbook
Set wb2 = Workbooks(serverfilename)
DataSheetName = InputBox("Please enter name of sheet where data is stored")
If DataSheetName = "" Then Exit Sub
Set RawDataWs = wb2.Sheets(DataSheetName)
Set ModifiedDataWs = Sheets.Add(After:=Sheets(Sheets.Count))
Newsheetname = InputBox("Please enter name of new sheet")
ModifiedDataWs.Name = Newsheetname
RawDataWsNotificationlrow = RawDataWs.Range("A" & Rows.Count).End(xlUp).Row
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
ModifiedDataWsNotificationlcolnum = ModifiedDataWs.Cells(1, Columns.Count).End(xlToLeft).Column + 1
ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)
Set RawDataWsNotificationRng = RawDataWs.Range("A2:A" & RawDataWsNotificationlrow)
Set ModifiedDataWsNotificationRng = ModifiedDataWs.Range("F1:" & ModifiedDataWsNotificationlcol & "1")
'------------------------------------TableFeatures---------------------------------------------
With ModifiedDataWs
.Cells(1, "A").Value = "Feature Code"
.Cells(1, "B").Value = "Zone"
.Cells(1, "C").Value = "Sheet"
.Cells(1, "D").Value = "Feature Description"
.Cells(1, "E").Value = "'-TEN OGV KH73126 tolerance"
.Cells(1, "F").Value = "'-TEN OGV KH73126 tolerance"
.Cells(2, "E").Value = "Nominal"
.Cells(2, "F").Value = "Tolerance"
'------------------------------------NotificationColumns---------------------------------------------
For Each cell In RawDataWsNotificationRng
Set ModifiedDataWsNotificationRng = .Range("G1:" & ModifiedDataWsNotificationlcol & "1")
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)
If FindNotificationNumber Is Nothing Then
ModifiedDataWsNotificationlcolnum = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)
Cells(1, ModifiedDataWsNotificationlcol).Value = cell.Value
End If
Next cell
'------------------------------------ZoneandSheetValues---------------------------------------------
Dim RawDataWsZoneRng As Variant: Set RawDataWsZoneRng = RawDataWs.Range("GB2:GB" & RawDataWsNotificationlrow)
Dim ModifiedDataWsZoneRng As Variant: Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B:B")
Dim ModifiedDataWssheetRng As Variant: Set ModifiedDataWssheetRng = ModifiedDataWs.Range("C:C")
Dim RawDataWsExtentRng As Variant: Set RawDataWsExtentRng = RawDataWs.Range("C2:C" & RawDataWsNotificationlrow)
Dim cel As Range
Dim ColumnLetterLRow, LR As Long, ColumnLetter As String, FindSheetinModifiedWs As Variant
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
For Each cell In RawDataWsZoneRng
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)
Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(what:=cell.Value, lookat:=xlWhole)
Set FindSheetinModifiedWs = ModifiedDataWssheetRng.Find(what:=RawDataWs.Cells(cell.Row, "FO"), lookat:=xlWhole)
If RawDataWs.Cells(cell.Row, "H").Value = "CONACC" Then
If FindZoneInModifiedWs Is Nothing Then
LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
Else
If Not FindZoneInModifiedWs Is Nothing And FindSheetinModifiedWs Is Nothing Then
LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
Else
If cell.Value <> vbNullString Then
ColumnLetter = Split(Cells(1, FindNotificationNumber.Column).Address, "$")(1)
If (.Cells(FindZoneInModifiedWs.Row, ColumnLetter) = vbNullString) Then
ColumnLetterLRow = FindZoneInModifiedWs.Row
Else
Set ColumnLetterRow = .Range(ColumnLetter & FindZoneInModifiedWs.Row & ":" & ColumnLetter & "30000").Find(what:="", lookat:=xlWhole)
ColumnLetterLRow = ColumnLetterRow.Row
End If
.Cells(ColumnLetterLRow, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(ColumnLetterLRow, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(ColumnLetterLRow, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
End If
End If
End If
End If
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
Next cell
'--------------------------Loop through zones and find input all values for zones-----------------
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B3:B" & ModifiedDataWsZoneLrow)
Dim nextrow As Long
For Each cell In ModifiedDataWsZoneRng
For Each cel In RawDataWsZoneRng
If cel.Value = cell.Value Then
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(What:=RawDataWs.Cells(cel.Row, "A"), lookat:=xlWhole)
Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(What:=cell.Value, lookat:=xlWhole)
If IsEmpty(.Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value) = True Then
.Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value = RawDataWs.Cells(cel.Row, "C").Value
.Cells(FindZoneInModifiedWs.Row, "B").Value = RawDataWs.Cells(cel.Row, "GB").Value
.Cells(FindZoneInModifiedWs.Row, "C").Value = RawDataWs.Cells(cel.Row, "FO").Value
Else
End If
End If
Next cel
Next cell
any ideas would be greatly appreciated! sorry i am new to VBA!
Old Data Sheet
New Sheet
Link to workbook
Link to workbook
Well, that more more complex than i'd thought but here goes:
'type to manage data we use from each row
Type dataRow
notif As Variant
variable As Variant
sht As Variant
zone As Variant
End Type
Sub DoPivot()
Const SEP As String = "<>"
Dim rngData As Range, data, r As Long
Dim colDict As Object, rowDict As Object, comboDict As Object
Dim rd As dataRow, rngOutput As Range, col As Long, rw As Long, k
Dim k2, arr, dictCounts As Object
Dim wsOut As Worksheet, num As Long
Set colDict = CreateObject("scripting.dictionary")
Set rowDict = CreateObject("scripting.dictionary")
Set comboDict = CreateObject("scripting.dictionary")
Set dictCounts = CreateObject("scripting.dictionary")
data = Sheet9.Range("A2:D4788").Value 'source data
Set rngOutput = Sheet9.Range("H1") 'top-left cell for output
Set wsOut = rngOutput.Parent
rngOutput.Resize(5000, 5000).ClearContents
rngOutput.Resize(1, 2).Value = Array("Sheet", "Zone")
col = rngOutput.Column + 2 'start for notification# headers
rw = rngOutput.row + 1
'first pass - assess data variables
For r = 1 To UBound(data, 1)
rd = rowData(data, r)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) 'tracking how many unique combinations of these
comboDict(k) = comboDict(k) + 1 'increment count
'manage column header positions for unique notification numbers
If Not colDict.exists(rd.notif) Then
colDict.Add rd.notif, col 'store the column
rngOutput.EntireRow.Cells(1, col).Value = rd.notif 'add the header
col = col + 1
End If
Next r
'figure out # of rows for each sheet-Zone pair
For Each k In comboDict.keys
arr = Split(k, SEP)
k2 = Join(Array(arr(0), arr(1)), SEP) 'sheet<>zone
'is this more rows than any previous same k2 value?
dictCounts(k2) = Application.Max(dictCounts(k2), comboDict(k))
Next k
'create the row headers
For Each k In dictCounts.keys
num = dictCounts(k)
rowDict(k) = rw 'record start row for each sheet<>zone combo
wsOut.Cells(rw, rngOutput.Column).Resize(num, 2).Value = Split(k, SEP)
dictCounts(k) = 0 'reset so we can track while adding data
rowDict(k) = rw
rw = rw + num
Next k
'last pass - populate the data based on the dictionaries
For r = 1 To UBound(data, 1)
rd = rowData(data, r)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) '3-field combo
k2 = Join(Array(rd.sht, rd.zone), SEP) 'row key
wsOut.Cells(rowDict(k2) + (dictCounts(k)), _
colDict(rd.notif)).Value = rd.variable
dictCounts(k) = dictCounts(k) + 1 'increment this unique combo
Next r
End Sub
'populate a Type instance for a given row
Function rowData(data, r As Long) As dataRow
Dim rv As dataRow
rv.notif = IfEmpty(data(r, 1))
rv.variable = IfEmpty(data(r, 2))
rv.sht = IfEmpty(data(r, 3))
rv.zone = IfEmpty(data(r, 4))
rowData = rv
End Function
'substitute EMPTY for zero-length value
Function IfEmpty(v)
IfEmpty = IIf(Len(v) = 0, "EMPTY", v)
End Function
EDIT: if you want to filter out certain rows then you need to modify the loops which iterate over data
For r = 1 To UBound(data, 1)
If data(r, colHere) <> "X" Then '<< add your filter here
rd = rowData(data, r)
'rest of code as before...
End If
Next r
Update
so i have added a count in, so if theres a match, add 1 to n. If not, n =0. If n = 1 then row = the number found. But why do i need to use a count why cant i use my original code.
lastrow = (subtaskws.Range("A" & Rows.Count).End(xlUp).row) + 1
lastcol = subtaskws.Cells(2, 1).End(xlToRight).Column
lastcollet = lastcol
lastcollet = Split(Cells(1, lastcol).Address, "$")(1)
lastrowST = subtaskws.Range("A" & Rows.Count).End(xlUp).row
activitynum = AddTask.TextBoxid.Value + 1
Dim Ctrl, ArrayID, userformorder As Variant, j As Long, range1 As Range, os As Integer, col, listitems As String, templatesubtaskrow As Range, tmeplatemilestonerow As Range, newrowadded As Range
userformorder = Array("SubTaskID", "TextBoxsubtask", "ComboBoxDeliverableFormat", "TextBoxcheckedcomplete", "TextBoxformat", "TextBoxacceptancecriteria", "BudgetWorkloadTextBox", "ComboBoxOwner", "TextBoxTDSNumber", "TextBoxMilestone", "TextBoxTargetDeliveryDate", "ComboBoxW", "ComboBoxI", "ComboBoxe", "TextBoxP", "TextBoxLevel", "TextBoxInputQuality", "TextBoxNewInput", "TextBoxDelay", "TextBoxInternalVV", "TextBoxReviewer", "TextBoxDelivered", "ComboBoxNumIterations", "ComboBoxAcceptance", "ComboBoxProgress", "ComboBoxStatus", "ComboBoxFlowChart", "TextBoxActivitySheet", "TextBoxEvidenceofDelivery", "TextBoxComments") 'etc
Set range1 = subtaskws.Range("A3:A" & lastrowST)
Set templatesubtaskrow = subtaskws.Range("A4:" & lastcollet & "4")
ArrayID = range1.Value
With subtaskws
n = 0
For j = LBound(ArrayID) To UBound(ArrayID)
If ArrayID(j, 1) = activitynum Then
n = n + 1
Else
n = n
End If
Next j
If n = 1 Then
newrow = j
Else
newrow = lastrow
End If
Set newrowadded = subtaskws.Range(IDCol & newrow)
Original Question
I have a userform that fills in a sheet labelled subtasks. However, sometimes the info being inserted may be in the middle of the sheet eg. row 64 out of 140.
I want to search the array for a set value (activtiynum) and when found, equal newrow to this newly found row number. If the activtiynum isnt found, then newrow should equal the lastrow + 1.
However, the code below wont work and displays the correct row number in the msgbox but then always adds a new row at the end
'find lastrows, columns and cells
lastrow = (subtaskws.Range("A" & Rows.Count).End(xlUp).row) + 1
lastcol = subtaskws.Cells(2, 1).End(xlToRight).Column
lastcollet = lastcol
lastcollet = Split(Cells(1, lastcol).Address, "$")(1)
lastrowST = subtaskws.Range("A" & Rows.Count).End(xlUp).row
activitynum = AddTask.TextBoxid.Value + 1
Dim Ctrl, ArrayID, userformorder As Variant, j As Long, range1 As Range, os As Integer, col, listitems As String, templatesubtaskrow As Range, tmeplatemilestonerow As Range, newrowadded As Range
userformorder = Array("SubTaskID", "TextBoxsubtask", "ComboBoxDeliverableFormat", "TextBoxcheckedcomplete", "TextBoxformat", "TextBoxacceptancecriteria", "BudgetWorkloadTextBox", "ComboBoxOwner", "TextBoxTDSNumber", "TextBoxMilestone", "TextBoxTargetDeliveryDate", "ComboBoxW", "ComboBoxI", "ComboBoxe", "TextBoxP", "TextBoxLevel", "TextBoxInputQuality", "TextBoxNewInput", "TextBoxDelay", "TextBoxInternalVV", "TextBoxReviewer", "TextBoxDelivered", "ComboBoxNumIterations", "ComboBoxAcceptance", "ComboBoxProgress", "ComboBoxStatus", "ComboBoxFlowChart", "TextBoxActivitySheet", "TextBoxEvidenceofDelivery", "TextBoxComments") 'etc
Set range1 = subtaskws.Range("A3:A" & lastrowST)
Set templatesubtaskrow = subtaskws.Range("A4:" & lastcollet & "4")
ArrayID = range1.Value
With subtaskws
For j = LBound(ArrayID) To UBound(ArrayID)
If ArrayID(j, 1) = activitynum Then
MsgBox range1(j).row
newrow = range1(j).row
Else
newrow = lastrow
End If
Next j
.Range("A" & newrow).EntireRow.Insert
Set newrowadded = subtaskws.Range(IDCol & newrow)
templatesubtaskrow.EntireRow.Copy Destination:=newrowadded
Based on your original code, you need something to tell it to exit the FOR LOOP. Otherwise, the next iteration after finding the match, it will potentially NOT find a match in the next cell. This causes the code to hit your ELSE code thereby changing newrow to lastrow. In addition the reason you say it "finds" it correctly is because you display the messagebox when it finds it. If that was moved outside of the FOR statement using 'newrow' it would not display the correct value.
Simplest solution, lets not do anything in the for loop that we don't need to and exit for when we match. We can set a variable indicating success or we can use your newrow variable (not yet intialized/dimmed) to determin success.
Note-This only works because you haven't initialized newrow as a variable. You might need to check it for NULL/EMPTY/0 if you dim it to begin with.
Also, added END WITH. Remove it if you have it later. Should be more consistent with the functionality.
Set newrowadded = subtaskws.Range(IDCol & newrow) appears to be IN the with statement but references the WITH object directly instead of .Range
See updated code below.
'find lastrows, columns and cells
lastrow = (subtaskws.Range("A" & Rows.Count).End(xlUp).row) + 1
lastcol = subtaskws.Cells(2, 1).End(xlToRight).Column
lastcollet = lastcol
lastcollet = Split(Cells(1, lastcol).Address, "$")(1)
lastrowST = subtaskws.Range("A" & Rows.Count).End(xlUp).row
activitynum = AddTask.TextBoxid.Value + 1
Dim Ctrl, ArrayID, userformorder As Variant, j As Long, range1 As Range, os As Integer, col, listitems As String, templatesubtaskrow As Range, tmeplatemilestonerow As Range, newrowadded As Range
userformorder = Array("SubTaskID", "TextBoxsubtask", "ComboBoxDeliverableFormat", "TextBoxcheckedcomplete", "TextBoxformat", "TextBoxacceptancecriteria", "BudgetWorkloadTextBox", "ComboBoxOwner", "TextBoxTDSNumber", "TextBoxMilestone", "TextBoxTargetDeliveryDate", "ComboBoxW", "ComboBoxI", "ComboBoxe", "TextBoxP", "TextBoxLevel", "TextBoxInputQuality", "TextBoxNewInput", "TextBoxDelay", "TextBoxInternalVV", "TextBoxReviewer", "TextBoxDelivered", "ComboBoxNumIterations", "ComboBoxAcceptance", "ComboBoxProgress", "ComboBoxStatus", "ComboBoxFlowChart", "TextBoxActivitySheet", "TextBoxEvidenceofDelivery", "TextBoxComments") 'etc
Set range1 = subtaskws.Range("A3:A" & lastrowST)
Set templatesubtaskrow = subtaskws.Range("A4:" & lastcollet & "4")
ArrayID = range1.Value
With subtaskws
For j = LBound(ArrayID) To UBound(ArrayID)
If ArrayID(j, 1) = activitynum Then 'If we match, set newrow to the matched row and then exit the loop
MsgBox range1(j).row
newrow = range1(j).row
Exit For
End If
Next j
'If newrow is empty it means we didn't match. Add newrow as last row.
If IsEmpty(newrow) Then
newrow = lastrow
.Range("A" & newrow).EntireRow.Insert
End If
End With 'Added END WITH as you go back to referencing subtasksws directly not using with syntax
Set newrowadded = subtaskws.Range(IDCol & newrow)
templatesubtaskrow.EntireRow.Copy Destination:=newrowadded