Have a 2d Array, need to search through one of the columns finding a string and deleting everything after it.
I have a list of dates, but the format it is currently in has a long Time value
after the date ending in 2019. I would like to find and replace 2019 + time
with just 2019.
Edit code
The date isn't stored as a date, for all intents and purposes it's a string that looks something like "****#### 2019 ######" and I am just looking for a method to remove everything after a value, (2019) .
Right now, it steps through it all nicely checks array value by value
but doesn't actually change anything.
Edit2
Found workable solution using Instr & Split functions.
BUT the weirdest bug crept in,
some dates appear fine in debug.print
eg : 11/06/2019 BUT after printing to a range 06/11/2019
13/06/2019 13/06/2019
Even if the format of the destination is pre-defined
Public Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
Private Sub Test()
Dim Name_col As Integer
Dim Date_col As Integer
Dim Hours_col As Integer
Dim Department_col As Integer
Dim Data_row As Integer
Name_col = 1
Date_col = 2
Hours_col = 3
Department_col = 4
Data_row = 2
Dim i As Integer
Dim zom As Integer
Dim DirArray As Variant
Dim col As Integer
Dim LString As String
Dim LArray() As String
zom = 0
i = 2
col = 2
Dim X As Integer
Application.ScreenUpdating = False
Do While Sheets("Sheet2").Cells(i, 1).Value <> ""
i = i + 1
zom = zom + 1
Loop
Application.ScreenUpdating = True
NumberOfZombies = zom
Debug.Print "Number of zombies" & NumberOfZombies
Worksheets("Sheet2").Activate
DirArray = Sheets("Sheet2").Range(Cells(Data_row, Name_col), Cells(zom, Department_col)).Value
For rw = LBound(DirArray) To UBound(DirArray)
For col = LBound(DirArray) To UBound(DirArray, 2)
LString = DirArray(rw, col)
If InStr(LString, "2019") > 0 Then
LArray = Split(LString)
Debug.Print LArray(0)
DirArray(rw, col) = LArray(0)
End If
Debug.Print DirArray(rw, col)
Next
Next
PrintArray DirArray, Sheets("Sheet3").[A1]
End Sub
Related
I have two data workbooks. One dataset is of refused orders and the other dataset is for current orders. I want to find if i can match orders so that i can utilize the orders that I have in refused file. This way i wont have to make the current order and can simultaneously reduce my stack of orders that have been refused by customers. Here is my Data sheets for refused and current/printed orders.
Current/Printed Orders
Here is datasheet for the refused orders.
Refused Orders
I need to match orders on three things. First the design name needs to match, the product name needs to match and the size needs to match in order to get an "order match".
How can I use excel vba to find matches and create a new excel worksheet in the current order workbook that can show the orders that match between both data sets. The final data output would be order number against order number from both the files.
I am just beginning to learn vba but this is a complex problem that i can not solve. Please help. I wrote a code but it does not run. It says object not defined. Code that i wrote is :
Sub Comparetwosheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1row As Long, ws2row As Long, w1scol As Integer, ws2col As Integer
Dim report As Worksheet
Dim row As Long, col As Integer
Dim R1 As Range
Set R1 = Union(col(5), col(7), col(10))
Set report = Worksheet.Add
'Set numrows = number of rows of data
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' Select cell a1.
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
x = 2
Do While x < NonBlank
x = x + 1
Do While (ws1.R1 = ws2.R1)
If ws1.rw2 = ws2.rw2 Then
report.Cells(1, 1).Value = "Match"
Else: x = x + 1
Loop
Loop
'Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
End Sub
This should be able to do it for you. You are able to set the following variables in the CompareWorksheet subroutine to what you need then to be (dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2). I am using a random dataset from the world bank.
Sub CompareWorksheet()
Dim dataSet1, dataSet2 As Variant
Dim workbook1, workbook2 As String
Dim worksheet1, worksheet2 As String
Dim rowStart1, rowStart2 As Integer
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook1 = "dashboard-data-latest1.xlsx"
worksheet1 = "2. Harmonized Indicators"
dataSet1 = SheetToDataSet(workbook1, worksheet1)
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook2 = "dashboard-data-latest.xlsx"
worksheet2 = "2. Harmonized Indicators"
dataSet2 = SheetToDataSet(workbook2, worksheet2)
'Set this do what columns you are interested in comparing
colPos1 = Array(1, 2, 3)
colPos2 = Array(1, 2, 3)
'Set for where you want to start 1 would be row 1/now Header.
rowStart1 = 2
rowStart2 = 2
'Compares the dataSets
Compare2Sheets dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2
End Sub
Function Compare2Sheets(dataSet1 As Variant, dataSet2 As Variant, colPos1 As Variant, colPos2 As Variant, rowStart1 As Variant, rowStart2 As Variant)
If UBound(colPos1) = UBound(colPos2) Then
For I = rowStart1 To UBound(dataSet1, 1)
For j = rowStart2 To UBound(dataSet2, 1)
matchFlag = 0
For k = 0 To UBound(colPos1)
If dataSet1(I, colPos1(k)) = dataSet2(j, colPos2(k)) Then
matchFlag = matchFlag + 1
End If
Next k
If matchFlag = (UBound(colPos1) + 1) Then
Debug.Print ("Match found in Workbook 1 at row " & I & " and Workbook 2 at row " & j)
End If
Next j
Next I
End If
End Function
Function SheetToDataSet(workbookName As Variant, worksheetName As Variant) As Variant
'SET PAGE CHARACTERISTICS
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'DECLARE VARIABLE
Dim x_matrix As Range
Dim x_copyrange As String
Dim length, lastColumn As Integer
'DEFINE VARIABLE
Workbooks(workbookName).Worksheets(worksheetName).Activate
length = 0
lastColumn = 0
For I = 1 To 10
If length < Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row Then
length = Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row
End If
If lastColumn < Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column Then
lastColumn = Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column + 10
End If
Next I
'Let x_copyrange = .Range(.Cells(1, 1), .Cells(length, lastColumn))
'Return
SheetToDataSet = Workbooks(workbookName).Worksheets(worksheetName).Range(Cells(1, 1), Cells(length, lastColumn))
End Function
I'm currently working with a workbook containing 34 different tabs.
I'm trying to extract Monthly Data from each of the tabs and Transpose it into daily figures for each specific city.
I have put all the dates within the year 2019 as columns in order to present it as daily figures. (See example in img below)
Each tab contains data for each specific city.
I always want to extract the data present on row 20 from column 4 to 15 in each tab for each specific city. ( see 2nd image below highlighted in yellow)
Public Sub CreateArray()
Dim myArrayOfMonths(11) As Double
Dim currentWorkbook As Workbook
Dim currentSheet As Worksheet
Dim otherSheet As Worksheet
Dim i As Integer
Dim r As Integer
Dim c As Integer
Dim j As Integer
Set currentWorkbook = ActiveWorkbook
Set otherSheet = currentWorkbook.Worksheets("Output")
i = 1
For Each currentSheet In currentWorkbook.Worksheets
r = 20
j = 0
For c = 4 To 15
myArrayOfMonths(j) = ActiveSheet.Cells(r, c)
j = j + 1
Next c
Debug.Print myArrayOfMonths(0)
i = i + 1
Next currentSheet
Set currentSheet = Nothing
Set currentWorkbook = Nothing
End Sub
In my code I'm trying to run through all of the tabs with a loop
and with a 2nd loop check the date (row 16, column 4 to 15) and extract it on my template (Similiar to a vlookup) Unfortunately, it never passes through the first tab as i=0 always for some reason.
Could you please advise?
Would you be able to do something like this?
Option Explicit
Public Sub PopulateOutput()
Dim outputSheet As Worksheet
Dim i As Integer
Set outputSheet = ActiveWorkbook.Worksheets("Output")
' starting at index 2 since output sheet looks like index 1
For i = 2 To ActiveWorkbook.Worksheets.Count
With ActiveWorkbook.Worksheets(i)
outputSheet.Range("B" & i & ":M" & i).Value = .Range("D20:O20").Value
End With
Next
End Sub
Does this suit your needs?
Public Sub CreateArray()
Dim myArrayOfMonths(11) As Double
Dim currentWorkbook As Workbook
Dim currentSheet As Worksheet
Dim otherSheet As Worksheet
Dim r As Integer
Dim c As Integer
Set currentWorkbook = ActiveWorkbook
Set otherSheet = currentWorkbook.Worksheets("Output")
For Each currentSheet In currentWorkbook.Worksheets
r = 20
For c = 4 To 15
myArrayOfMonths(c - 4) = myArrayOfMonths(c - 4) + currentSheet.Cells(r, c)
Next c
Next currentSheet
otherSheet.Range("B1:M1").Value = myArrayOfMonths
Set currentSheet = Nothing
Set currentWorkbook = Nothing
End Sub
Use currentSheet.Cells(r,c) instead of ActiveSheet
or use currentSheet.Activate and then myArrayOfMonths(j) = ActiveSheet.Cells(r, c), but try to avoid ActiveSheet.
Sub Projektlaufzeit()
Dim Datum1 As Date, msg As String
Dim Datum2 As Date
Dim Rest As Long
Dim Projektname As String
Dim i As Integer
Dim c As Integer
Dim ber As Range
Projektname = Range("A2")
Datum1 = Date
'Datum2 = Tabelle1.Range("C2")
c = Sheets("tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Column
For i = 2 To c
Projektname = Cells(i, 1)
Datum2 = Cells(i, 3)
Rest = DateDiff("d", Datum1, Datum2)
If Rest > 7 And Rest < 30 Then MsgBox "something"
If Rest >= 0 And Rest <= 7 Then MsgBox "something"
If Rest <= 0 Then MsgBox "something"
Next i
Dim FilterArray
Dim List As Range
Set List = ActiveSheet.Range("A:A")
List.AutoFilter
FilterArray = Array(Projektname)
List.AutoFilter Field:=1, Criteria1:=Array(FilterArray)
End Sub
So that is my code so far. I have a Loop which tells me when a certain project will come to an end. That works so far.
The next step is, that the macro will autofilter all projects that have a remaining duration of < 30 days.
In my code obviously only the last project that was affected by the loop will be filtered. Is it possible to create an array with all affected projects?
I attached a screenshot of the Excel Worksheet.
Thanks in advance.
If you imagine that all your dates are numbers and your target is to create an array of the values in column A, that
correspond to some condition, then this is a possible input:
With the code below, the condition is translated as:
Projects with remaining duration less or equal than 2 days and not finished with today's date.
Option Explicit
Sub ProjectTime()
Dim lngDateToday As Long
Dim lngRemainingDuration As Long
Dim lngLastRow As Long
Dim lngCounter As Long
Dim varProjects() As Variant
Dim blnFirst As Boolean
blnFirst = True
lngDateToday = Range("D2")
lngRemainingDuration = Range("E2")
lngLastRow = 13
ReDim varProjects(0)
For lngCounter = 2 To lngLastRow
If Cells(lngCounter, 3) < (lngDateToday + lngRemainingDuration) And _
Cells(lngCounter, 3) >= lngDateToday Then
If Not blnFirst Then
ReDim Preserve varProjects(UBound(varProjects) + 1)
End If
blnFirst = False
varProjects(UBound(varProjects)) = Cells(lngCounter, 1)
End If
Next lngCounter
For lngCounter = LBound(varProjects) To UBound(varProjects)
Debug.Print varProjects(lngCounter)
Next lngCounter
End Sub
Thus, projects E,G and I (highlighted) are the one matched and added to the array of values. As far as we are not using a collection, but an array, I am redim-ing and preserving on every step (except for the first one).
To filter the array, you need to add the array as a parameter to the filter. Add the following to the end of the code:
Dim List As Range
Set List = ActiveSheet.Range("A:A")
List.AutoFilter
List.AutoFilter field:=1, Criteria1:=Array(varProjects), Operator:=xlFilterValues
This is how it should look like:
I'm currently using this template to log employee holiday requests
http://office.microsoft.com/en-gb/templates/employee-absence-schedule-TC103987167.aspx
I have added array formulas to give the specific number of days each month that an employee has had a Holiday / Unpaid leave / Sick / Late etc
eg
=SUM(LEN(B5:AF5)-LEN(SUBSTITUTE(B5:AF5,"H","")))/LEN("H")
and combined these totals to get a year overview but I still have to look through the sheets to get a full list of days they have requested and copy out the data.
Is there a formula I can put in so I can make a sheet for each employee that when H appears On sheet January B8-AF8 write sheet month name and the corresponding day and date in row 4.
I'm trying to achieve something like this as an automatic function?
I'm currently unable to post images but if you need me to elaborate please let me know.
If I understand correctly, you want 1 sheet per employee? As far as I know there isn't a way of adding sheets automatically without using some code (VBA or otherwise). If you had the sheets already created then I'm sure that we could come up with a formula.
Anyway, here is some VBA code you can try out...It creates a new workbook to summarize the data in. There isn't any error checking and it assumes that you're running it from the template that you provided. Just add a button that calls EmployeeSummary and it should work.
Type DayOffType
Month As String
DayOfWeek As String
Date As String
Type As String
End Type
Type EmployeeType
Name As String
DaysOff() As DayOffType
NumberOfDaysOff As Long
End Type
Private EmployeeData() As EmployeeType
Private EmployeeCount As Long
Sub EmployeeSummary()
Dim wb As Excel.Workbook
Call ReadSchedule(ThisWorkbook)
Set wb = Workbooks.Add
Call WriteSummary(wb, "H")
End Sub
Sub ReadSchedule(Book As Excel.Workbook)
Dim tbl As Excel.Range
Dim TableName As String
Dim sMonth As String, sDay As String
Dim iMonth As Integer, iDate As Integer
Dim iEmployee As Long, iRow As Long, iCol As Long
For iMonth = 1 To 12
sMonth = MonthName(iMonth)
With Book.Worksheets(sMonth)
TableName = "tbl" & sMonth
Set tbl = .ListObjects(TableName).Range
For iRow = 2 To tbl.Rows.Count - 1
iEmployee = GetEmployee(tbl.Cells(iRow, 1))
For iCol = 2 To tbl.Columns.Count - 1
If tbl.Cells(iRow, iCol) <> vbNullString Then
AddDayOff iEmployee, sMonth, tbl, iRow, iCol
End If
Next
Next
End With
Next
End Sub
Private Function GetEmployee(Name As String)
Dim i As Long
For i = 0 To EmployeeCount - 1
If EmployeeData(i).Name = Name Then Exit For
Next
If i >= EmployeeCount Then
ReDim Preserve EmployeeData(EmployeeCount)
EmployeeData(EmployeeCount).Name = Name
EmployeeCount = EmployeeCount + 1
End If
GetEmployee = i
End Function
Private Sub AddDayOff(Employee As Long, Month As String, Table As Range, Row As Long, Col As Long)
With EmployeeData(Employee)
ReDim Preserve .DaysOff(.NumberOfDaysOff)
With .DaysOff(.NumberOfDaysOff)
.Date = Table.Cells(1, Col)
.DayOfWeek = Table.Cells(0, Col)
.Month = Month
.Type = Table.Cells(Row, Col)
End With
.NumberOfDaysOff = .NumberOfDaysOff + 1
End With
End Sub
Private Sub WriteSummary(Book As Excel.Workbook, Optional AbsenceType As String = "H")
Dim ws As Excel.Worksheet
Dim cell As Excel.Range
Dim i As Long, d As Long
Set ws = Book.Worksheets(1)
For i = 0 To EmployeeCount - 1
With ws
.Name = EmployeeData(i).Name
.Range("A1") = EmployeeData(i).Name
Set cell = .Range("A2")
For d = 0 To EmployeeData(i).NumberOfDaysOff - 1
If EmployeeData(i).DaysOff(d).Type = AbsenceType Then
cell = EmployeeData(i).DaysOff(d).Month
cell.Offset(0, 1) = EmployeeData(i).DaysOff(d).DayOfWeek
cell.Offset(0, 2) = EmployeeData(i).DaysOff(d).Date
Set cell = cell.Offset(1, 0)
End If
Next
End With
Set ws = Book.Worksheets.Add(after:=Book.Worksheets(Book.Worksheets.Count))
Next
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub
Here is the VBA function that populates an array with a unique set of months, generated from a start month and an end month:
Function get_months(matrix_height As Integer) As Variant
Worksheets("Analysis").Activate
Dim date_range As String
Dim column As String
Dim uniqueMonths As Collection
Set uniqueMonths = New Collection
Dim dateRange As range
Dim months_array() As String 'array for months
column = Chr(64 + 1) 'A
date_range = column & "2:" & column & matrix_height
Set dateRange = range(date_range)
On Error Resume Next
Dim currentRange As range
For Each currentRange In dateRange.Cells
If currentRange.Value <> "" Then
Dim tempDate As Date: tempDate = CDate(currentRange.Text) 'Convert the text to a Date
Dim parsedDateString As String: parsedDateString = Format(tempDate, "MMM-yyyy")
uniqueMonths.Add Item:=parsedDateString, Key:=parsedDateString
End If
Next currentRange
On Error GoTo 0 'Enable default error trapping
'Loop through the collection and view the unique months and years
Dim uniqueMonth As Variant
Dim counter As Integer
counter = 0
For Each uniqueMonth In uniqueMonths
ReDim Preserve months_array(counter)
months_array(counter) = uniqueMonth
Debug.Print uniqueMonth
counter = counter + 1
Next uniqueMonth
get_months = months_array
End Function
How can I manipulate this function to return the cell rows of each of the values that are being added to my months array.
What would be the best way to store these two values i.e. The Date (Oct-2011) & the Row Number (i.e. 456)
Tow arrays? Then return an array with these two arrays within it?
Can anyone give provide a solution to this problem?
NOT FULLY TESTED
Just a quick example I threw together think this is what you are looking for, let me know of any changes you may need and I'd be glad to help.
This is sloppy and unfinished but working, as far as I know, Test in a copy of your actual data and not on your actual data. When I get some more time I can try to clean up more.
Function get_months(matrix_height As Integer) As Variant
Dim uniqueMonth As Variant
Dim counter As Integer
Dim date_range() As Variant
Dim column As String
Dim uniqueMonths As Collection
Dim rows As Collection
Set uniqueMonths = New Collection
Set rows = New Collection
Dim dateRange As Range
Dim months_array() As String 'array for months
date_range = Worksheets("Analysis").Range("A2:A" & matrix_height + 1).Value
On Error Resume Next
For i = 1 To matrix_height
If date_range(i, 1) <> "" Then
Dim parsedDateString As String: parsedDateString = Format(date_range(i, 1), "MMM-yyyy")
uniqueMonths.Add Item:=parsedDateString, Key:=parsedDateString
If Err.Number = 0 Then rows.Add Item:=i + 1
Err.Clear
End If
Next i
On Error GoTo 0 'Enable default error trapping
'Loop through the collection and view the unique months and years
ReDim months_array(uniqueMonths.Count, 2)
For y = 1 To uniqueMonths.Count
months_array(y, 1) = uniqueMonths(y)
months_array(y, 2) = rows(y)
Next y
get_months = months_array
End Function
And can be called like:
Sub CallFunction()
Dim y As Variant
y = get_months(WorksheetFunction.Count([A:A]) - 1)
End Sub
Function:
Function get_months() As Variant
Dim UnqMonths As Collection
Dim ws As Worksheet
Dim rngCell As Range
Dim arrOutput() As Variant
Dim varRow As Variant
Dim strRows As String
Dim strDate As String
Dim lUnqCount As Long
Dim i As Long
Set UnqMonths = New Collection
Set ws = Sheets("Analysis")
On Error Resume Next
For Each rngCell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)).Cells
If IsDate(rngCell.Text) Then
strDate = Format(CDate(rngCell.Text), "mmm-yyyy")
UnqMonths.Add strDate, strDate
If UnqMonths.Count > lUnqCount Then
lUnqCount = UnqMonths.Count
strRows = strRows & " " & rngCell.Row
End If
End If
Next rngCell
On Error GoTo 0
If lUnqCount > 0 Then
ReDim arrOutput(1 To lUnqCount, 1 To 2)
For i = 1 To lUnqCount
arrOutput(i, 1) = UnqMonths(i)
arrOutput(i, 2) = Split(strRows, " ")(i)
Next i
End If
get_months = arrOutput
End Function
Call and output:
Sub tgr()
Dim my_months As Variant
my_months = get_months
With Sheets.Add(After:=Sheets(Sheets.Count))
.Range("A2").Resize(UBound(my_months, 1), UBound(my_months, 2)).Value = my_months
With .Range("A1:B1")
.Value = Array("Unique Month", "Analysis Row #")
.Font.Bold = True
.EntireColumn.AutoFit
End With
End With
End Sub