VBA pasting array date values in different format - arrays

I have a simple macro that includes a dynamic array which fills up upon conditions are met. The data populates the macro as it is supposed to be functioning until it paste the data onto the spreadsheet. Now, all data is pasted correctly except for date values. Date values are pasted erroneously from European format to American format onto the spreadsheet (i.e. dd-mm-yyyy to mm-dd-yyyy). So for instance a 1st march 2019 becomes a 3rd January 2019 on the spreadsheet. Note that either I format beforehand the destination files or not, the problem still occurs.
The array has 14 columns and only column 12-13 are date values.
Edit Summary
Shredded the code from irrelevant information; added images of results.
Following is the code
Sub Verification()
Dim NewWorkbook As String, NewWorksheet As String
Dim wb As Workbook, sh As Worksheet
Dim LoopCounter As Long
Dim NewEntryCounter As Long
Dim Cols As Long, Rows As Long
Dim r As Range
Dim arr As Variant, NewEntry() As Variant
Dim myRange As Integer
NewWorkbook = LCase(InputBox("What is the name of the new report?"))
NewWorksheet = LCase(InputBox("What is the name of the sheet?"))
Set wb = ThisWorkbook
Set sh = wb.Sheets("Renouvellement")
Cols = Workbooks(NewWorkbook).Sheets(NewWorksheet).Range(Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1), Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1).End(xlToRight)).Count
Rows = sh.Range(sh.Cells(1, 1), sh.Cells(1, 1).End(xlDown)).Count
For Each r In Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A2", Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A1").End(xlDown))
If (r.Offset(0, 21).Text = "Red" Or r.Offset(0, 21).Text = "Blue") And r.Offset(0, 17).Value >= 24 Then
arr = Application.VLookup(r.Value, sh.Range("A:A"), 1, 0)
If IsError(arr) Then
NewEntryCounter = NewEntryCounter + 1
ReDim Preserve NewEntry(1 To Cols, 1 To NewEntryCounter)
For LoopCounter = 1 To Cols
NewEntry(LoopCounter, NewEntryCounter) = r.Offset(0, LoopCounter - 1)
Next LoopCounter
Else
End Sub
Sample results from Local window
Sample results when transferring date values onto spreadsheet
As you can see the first value inserted is changed when transferring data from vba to spreadsheet. The second value is correctly transferred. The third is not, and so on.

Again, it's a bit difficult for me to understand exactly what you're doing, but it seems that a filter might be simpler, so far as the copying of relevant data is concerned.
In your code, you are making multiple calls to the worksheet, and multiple Redim Preserve operations on the VBA array. Those operations can be costly.
Perhaps that part of the code could be simplified (and sped up) with something like (obviously, you may need to change the worksheet and range variables):
Set ws = Worksheets("sheet1")
Set r = ws.Range("a1").CurrentRegion
With r
.AutoFilter field:=22, Criteria1:="red", Operator:=xlOr, Criteria2:="blue"
.AutoFilter field:=18, Criteria1:=">=24"
End With
r.SpecialCells(xlCellTypeVisible).Copy
'Paste somewhere
ws.ShowAllData

Related

How to convert ranges to arrays - nested loops - excel vba

It has been a long time since I converted ranges to arrays. I have a list of 500 stock tickers in column D and associated stock names in column E. The list repeats itself every month, and I have 13 months of data. Problem is that sometimes the name changes when I add the new month's data, e.g., ATandT may become AT&T while the symbol remains "T". But the name must be consistent for all 13 months of data in the database. The following code uses two For Next loops to update the names in the prior 12 months of data with the newest names from the 13th month. It works well, but is obviously slow. If I convert the ranges to arrays, it will run much faster. Can someone give me a start with this. Thanks.
Sub changeRows()
Dim ws As Worksheet, rw As Long, lastrow As Long, tkr As String
Dim rw2 As Long, stk As String
Set ws = ActiveSheet
ws.Activate
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For rw2 = 11936 To lastrow
tkr = Cells(rw2, 4)
stk = Cells(rw2, 5)
For rw = 2 To 11935
If ws.Cells(rw, 4) = tkr Then
ws.Cells(rw, 5) = stk
End If
Next rw
Next rw2
End Sub

VBA Excel: which one is better and faster: using one variant matrix for a range or several arrays for each column?

I need to use values from several columns based on a row value. Is it better and faster to create variant matrix array and store all columns in that array then search and deploy values from that array, or create an array for each column, considering that there can be several thousand rows and the values are used multiple times?
Example: We have the following data:
If the person joined before 01-Jan-13, I want to deduct due amount from equity. Is it better to declare a variant array like
Dim matrix() as Variant
Dim ws as Worksheet
Dim cols(4) as String: cols(0) = "A': cols(1) = "B": cols(2) = "C": cols(3) = "D"
Dim i as Integer
Dim b as Integer: b = 2 'beginning row
Dim j as Integer: j = 4 'number of lines
Set ws = Worksheets("Sheet1")
For i = 0 to UBound(cols)
matrix(i) = Range(cols(i) & b & ":" & cols(i) & (b + j)).value2
End if
or
Declare separate four arrays, like
Dim arr1() as String
Dim arr2() as Date
Dim arr3() as Integer
Dim arr4() as Integer
Of course I can directly use data from cells by directly referencing cells as well, but as I use this multi-thousand-row data multiple times it makes more sense to store them in array.
If there are many columns, it may be noticeably faster to read all the data into a single matrix in one go. There is a large overhead with every transfer of data between Excel and VBA. A larger data transfer is not much slower than a small data transfer, but many data transfers is a lot slower than a single transfer.
Here is an excellent source of detail:
Data transfer between worksheet cells and VBA variables is an expensive operation that should be kept to a minimum. You can considerably increase the performance of your Excel application by passing arrays of data to the worksheet, and vice versa, in a single operation rather than one cell at a time. If you need to do extensive calculations on data in VBA, you should transfer all the values from the worksheet to an array, do the calculations on the array, and then, possibly, write the array back to the worksheet. This keeps the number of times data is transferred between the worksheet and VBA to a minimum. It is far more efficient to transfer one array of 100 values to the worksheet than to transfer 100 items at a time.
http://www.cpearson.com/excel/ArraysAndRanges.aspx
Copy a Range to an Array and Vice Versa
Option Explicit
Sub DeductDue()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Reference the data (no headers) range ('rg').
Dim rg As Range
With ws.Range("A1").CurrentRegion
Set rg = .Resize(.Rows.Count - 1).Offset(1)
End With
' Write the values from columns 2-4 ('Date' to 'Due') to an array ('sData').
Dim sData As Variant: sData = rg.Columns(2).Resize(, 3).Value
' Wrtie the values from column 6 ('Equity') column to an array ('dData').
Dim dData As Variant: dData = rg.Columns(6).Value
' Loop through the rows of the arrays and calculate...
Dim r As Long
For r = 1 To rg.Rows.Count
If Year(sData(r, 1)) < 2013 Then
dData(r, 1) = dData(r, 1) - sData(r, 3)
End If
Next r
' Write the result to a column range, e.g.:
rg.Columns(6).Value = dData ' overwrite Equity with the deducted values
End Sub

Create a VBA Array from Column Headers?

I have a an export "NewExport" that always randomizes the columns of data I receive. I need these columns to align with the order of columns in "TheOrder", so this code will help to re-organize the export to align with the column headers I've already built.
I have 132 columns that need re-alignment, and while I can type it all out, there must be an easier way to align with the column headers I've already created. It should be noted that the below code is shamelessly copy/pasted from another StackOverflow answer.
Sub OrderColumns(ByVal NewExport As Workbook, ByVal TheOrder As Worksheet)
Dim correctOrder() As Variant
Dim lastCol As Long
Dim headerRng As Range, cel As Range
Dim mainWS As Worksheet
Set mainWS = NewExport.Worksheets("Sheet1")
'Need to figure out how to make this an array based on a Range
correctOrder() = Array(TheOrder.Range("A1:A132").Value)
With mainWS
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set headerRng = .Range(.Cells(1, 1), .Cells(1, lastCol))
End With
Dim newWS As Worksheet
Set newWS = Ninja.Sheets.Add
newWS.Name = "Rearranged Sheet"
Dim col As Long
With newWS
For col = 1 To lastCol
For Each cel In headerRng
If cel.Value = correctOrder(col - 1) Then
mainWS.Columns(cel.Column).Copy .Columns(col)
Exit For
End If
Next cel
Next col
End With
End Sub
While it's not as automated as I would have liked (and requires one piece of hard-coding), I was able to find a solution as such:
Dim correctOrder(132) As Variant
'132 will need to be changed if there's ever any more/less columns added/excluded
For i = 1 To 132
correctOrder(i - 1) = TheOrder.Range("A" & i).Value
Next
This solution gave me the array I was looking for for use later on.
I recently wrote a 'column finder' function for a project of mine.
I've modified it to suit your requirements below.
The function requires you pass the workbook your correct ordered headings are in to capture. You could modify this to require your TargetWorksheet instead so it's a bit more dynamic.
The function returns a single dimension Array.
The function finds the last used Column in the Target Worksheet allowing for changes in the number of column headings (as mentioned in your own answer which has the column number hard coded).
Public Function CorrectOrderHeadingsArrayFunction(ByRef TargetWorkbook As Workbook) As Variant()
With TargetWorkbook.Sheets(1) 'Change this to target your correct sheet
Dim LastColumn As Long
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
CorrectOrderHeadingsArrayFunction= Application.Transpose(Application.Transpose(.Range(.Cells(1, 1), .Cells(1, LastColumn)).Value)) 'This returns the array as single dimension rather than 2D
End With
End Function
As an example, below is some sample 'Test' code to show the concept of using this function .
You could call it like so, and loop through each element perhaps comparing another arrays elements to the correct order elements and do something when the correct order value is found.
Sub TestSub()
Dim CorrectOrderArray As Variant
Dim TargetCorrectOrderElement As Variant
Dim RandomOrderArray As Variant
Dim TargetRandomOrderElement As Variant
CorrectOrderArray = CorrectOrderHeadingsArrayFunction(Workbooks("Export (4).csv")) 'Change this to target your correct workbook
RandomOrderArray = Sheet1.Range("A1:AZ1000") 'Change this to target the correct range for your data.
For Each TargetCorrectOrderElement In CorrectOrderArray
For TargetRandomOrderElement = LBound(RandomOrderArray) To UBound(RandomOrderArray)
If RandomOrderArray(TargetRandomOrderElement) = TargetCorrectorderValue Then
'Do some code to write that column to your worksheet
Exit For 'Leaves the current iteration of the random order array loop to go to the next iteration of the correct order array
End If
Next TargetRandomOrderElement
Next TargetCorrectOrderElement
End Sub

Losing milliseconds when processing timestamps in array

I am crunching numbers with VBA in Excel using data imported from a text file. The timestamp data is in the form, "dd-mmm-yyyy hh:mm:ss.000", and the number format is set to "dd-mmm-yyyy hh:mm:ss.000" for the whole column. After import, the imported column matches the text file exactly (e.g., 16-Mar-2020 16:10:15.175).
As part of the number-crunching, I read the imported column into a variant array called timestamp:
Dim timestamp As Variant
timestamp = Range(.Cells(1, Timestamp_Column), .Cells(NumRows, Timestamp_Column))
When I examine the data with a breakpoint, it is formatted as a date, but no timestamp is visible. It is formatted as: #16-Mar-20 4:10:15 PM#
I then paste it into a destination sheet that has the same number format assigned as the original data:
Private Function FillColumnData(theArray As Variant, transpose As Boolean, _
sheetname As String, destCol As Integer) As Variant
Dim destColRange As Range
Dim tempArray as Variant
Dim maxrow As Long
maxrow = NumRows()
' Transpose the array?
If (transpose) Then
tempArray = TransposeArray(theArray) ' Transpose the array
Else
tempArray = theArray ' The timestamp array is not transposed
End If
With Sheets(sheetname)
Set destColRange = .Columns(destCol)
Set destColRange = destColRange.resize(maxrow, 1)
destColRange.value = tempArray
End With
The resulting column is complete and matches the original column data, except all the millisecond values are 0: e.g., original = "16-Mar-2020 16:10:15.175"; copy = "16-Mar-2020 16:10:15.000".
Is there something I could force when pasting the array back to the destination sheet?
Thanks in advance for any help!
Passing dates to/from VBA/worksheet is sometimes tricky. Excel stores dates as serial numbers with 1 = 1-Jan-1900. VBA as an explicit Date data type.
Easiest would be to replace your assignment statement with:
timestamp = Range(.Cells(1, Timestamp_Column), .Cells(NumRows, Timestamp_Column)).Value2
That way you are passing a Double rather than a Date data type.
An alternative would be to loop through your timestamp array, replacing each element with CDbl(timestamp(x,y)), but it seems more efficient to access that value directly using the Value2 property.
That will provide the unformatted value and include the milliseconds
Proof of Concept Code
Option Explicit
Sub dtStuff()
Dim R As Range: Set R = Range("A1:a2")
Dim v, w
v = R
w = R.Value2
With R.Offset(0, 1)
.NumberFormat = R.NumberFormat
.Value = v
End With
With R.Offset(0, 2)
.NumberFormat = R.NumberFormat
.Value = w
End With
End Sub

Cut and paste row if columns AC-AF contain blanks

What I am trying to accomplish is this:
If any cells in columns AC-AF in my entire worksheet are blank, cut the entire row and paste to a new worksheet labeled "MissingShipping".
Code should adjust with the amount of rows, since that will never be the same.
From examples I have seen I don't understand where to insert the range of the cells I want to wade through.
I get the error
"Method 'Range' of object'_Worksheet'
on the line NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, lastcolumn)).Select.
Option Explicit
Sub Shipping()
Dim MissingShipping As Worksheet
Set MissingShipping = Sheets.Add(After:=Sheets(Sheets.Count))
MissingShipping.Name = "MissingShipping"
Dim NewSetup As Worksheet
Dim lastcolumn As Integer
Dim Destinationrow As Integer
Dim lastrow As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
Destinationrow = 1
lastcolumn = NewSetup.Range("XFD1").End(xlToLeft).Column
lastrow = NewSetup.Range("A1048576").End(xlUp).Row
Dim i As Long
Dim j As Long
For i = lastrow To 1 Step -1
For j = 1 To lastcolumn
If NewSetup.Cells(i, j).Value = "" Then
NewSetup.Activate
NewSetup.Range(Cells(i, 1), Cells(i, lastcolumn)).Cut
MissingShipping.Activate
NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, _
lastcolumn)).Select
ActiveSheet.Paste
NewSetup.Rows(i).Delete shift:=xlUp
Destinationrow = Destinationrow + 1
Exit For
End If
Next j
Next i
End Sub
G'day Nikki,
Welcome to the world of VBA! There are plenty of great resources on the internet to help you on your journey.
It's often easier and faster to work with a range inside your code instead of reading and writing to a sheet and selecting cells to mimic things that you would normally do if you were doing the job manually.
It's a good idea to get your head around the range object early on. It's handy for working with multiple worksheets.
The following is a good start with Ranges in Excel:
https://excelmacromastery.com/excel-vba-range-cells/
Another handy thing is a collection. If you had to store a bunch of things to work with later on, you can add them to a collection then iterate over them using a "For Each" loop. This is a good explanation of collections:
https://excelmacromastery.com/excel-vba-collections/
I had a quick look at your code and using the concept of Ranges and Collections, I have altered it to do what I think you were trying to do. I had to make a few assumptions as I haven't seen you sheet. I ran the code on a bunch of random rows on my computer to make sure it works. Consider the following:
Dim MissingShipping As Worksheet
Dim NewSetup As Worksheet
Dim rangeToCheck As Range
Dim cellsToCheck As Range
Dim targetRange As Range
Dim rw As Range 'rw is a row
Dim cl As Range 'cl is a cell
Dim rowColl As New Collection
Dim i As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
'Get the range of data to check
Set rangeToCheck = NewSetup.Range("A1").CurrentRegion
'For each row in the range
For Each rw In rangeToCheck.Rows
'For the last four cells in that row
Set cellsToCheck = rw.Cells(1, 29).Resize(1, 4)
For Each cl In cellsToCheck.Cells
'If the cell is empty
If cl.Value = "" Then
'Add the row to our collection of rows
rowColl.Add rw
'Exit the for loop because we only want to add the row once.
'There may be multiple empty cells.
Exit For
End If
'Check the next cell
Next cl
Next rw
'Now we have a collection of rows that meet the requirements that you were after
'Using the size collection of rows we made, we now know the size of the range
'we need to store the values
'We can set the size of the new range using rowColl.Count
'(that's the number of rows we have)
Set targetRange = MissingShipping.Range("A1").Resize(rowColl.Count, 32)
'Use i to step through the rows of our new range
i = 1
'For each row in our collection of rows
For Each rw In rowColl
'Use i to set the correct row in our target range an make it's value
'equal to the row we're looking at
targetRange.Rows(i) = rw.Value
'Increment i for next time
i = i + 1
Next rw
End Sub
Good luck! Hope this helps.

Resources