• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Strange date behaviour

Hi Experts,


I am facing a strange date behavior. I am copying data to one sheet from another by a macro. in the master sheet dates are "OK" but in sheet generated by macro date are not as expected. i have tried format painter as well but no success. Although if press F2 and enter i become "OK" Its a bit difficult to explain so please find the link of file at http://sdrv.ms/NmcYUw


Regards,
 
Hi mercatog,


Its your gem code....

[pre]
Code:
For i = 1 To Number_Of_Rows
Application.StatusBar = Format(i / Number_Of_Rows, "0%")
Customer_Name = Row_Array(i, 1)
Check_Date = Row_Array(i, 9)
Additional_Check = Row_Array(i, 11)

If Customer_Name = Record_Array(1, 1) Then
If Check_Date >= Record_Array(1, 4) And Check_Date <= Record_Array(1, 5) Then
If Record_Array(1, 7) = "" Or Additional_Check = Record_Array(1, 7) Then
Row_Counter = Row_Counter + 1
ReDim Preserve Tmp(1 To Number_Of_Columns, 1 To Row_Counter)
For j = 1 To Number_Of_Columns
Tmp(j, Row_Counter) = Row_Array(i, j)
Next j
End If
End If
End If
Next i
[/pre]
End With

Full code at :


http://chandoo.org/forums/topic/need-a-fix-to-enable-this-marco-in-my-existing-workbook-6#post-38230


incorporating suggestion given at http://chandoo.org/forums/topic/need-a-fix-to-enable-this-marco-in-my-existing-workbook-6#post-38249


Regards,
 
I remember the topic. But without a sample file, it's difficult to answer exactly.

Your system date is dd/mm/yyyy or mm/dd/yyyy?
 
Since Row_Array is defined as a Variant, it's possible the dates are getting copied as strings. This would explain why they look ok, and get corrected after you "edit" the cell. Might try changing that whole With section to this:

[pre]
Code:
Dim MyRange As Range
Set MyRange = ThisWorkbook.Worksheets("Supply Data").Range("Supply_Data")
With MyRange
Number_Of_Rows = .Rows.Count
Record_Array = ThisWorkbook.Worksheets("Dashboard").Range("A21:G21").Value
Number_Of_Columns = .Columns.Count

For i = 1 To Number_Of_Rows
Application.StatusBar = Format(i / Number_Of_Rows, "0%")
Customer_Name = MyRange(i, 1).Value
Check_Date = MyRange(i, 9).Value
Additional_Check = MyRange(i, 11).Value

If Customer_Name = Record_Array(1, 1) Then
If Check_Date >= Record_Array(1, 4) And Check_Date <= Record_Array(1, 5) Then
If Record_Array(1, 7) = "" Or Additional_Check = Record_Array(1, 7) Then
Row_Counter = Row_Counter + 1
ReDim Preserve Tmp(1 To Number_Of_Columns, 1 To Row_Counter)
For j = 1 To Number_Of_Columns
Tmp(j, Row_Counter) = MyRange(i, j).Value
Next j
End If
End If
End If
Next i
End With
[/pre]
Big change is that it uses the MyRange range object instead of a Variant array. This should help keep the components in their correct syntax.


Of course, all of this assumes that the destination sheet wasn't preformatted to text format. =P
 
Humm...Let me do a performance test. Actually supply_data is A2:Y150000 and i doubt this will slow down execution time. Else i will need to dig out the root cause to eliminate this.


Regards,
 
Hi

Try this and adapte to your file (I suppose that columns 3, 4 and 9 of worksheet Supply Data are date)

[pre]
Code:
Public Sub Copy_Supply_Data()
Dim LastLig As Long, Number_Of_Rows As Long, Row_Counter As Long, i As Long, Check_Date As Long
Dim Row_Array As Variant, Record_Array As Variant, Tmp() As Variant
Dim Customer_Name As String, Additional_Check As String
Dim Number_Of_Columns As Integer, j As Integer
Dim WherePaste As Range
Dim User_Input As Byte

Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Supply Data").Range("Supply_Data")
Number_Of_Rows = .Rows.Count
Number_Of_Columns = .Columns.Count
Row_Array = .Value

Record_Array = ThisWorkbook.Worksheets("Dashboard").Range("A21:G21").Value

For i = 1 To Number_Of_Rows
Customer_Name = Row_Array(i, 1)
Check_Date = CLng(Row_Array(i, 9))
Additional_Check = Row_Array(i, 11)

If Customer_Name = Record_Array(1, 1) Then
If Check_Date >= CLng(Record_Array(1, 4)) And Check_Date <= CLng(Record_Array(1, 5)) Then
If Record_Array(1, 7) = "" Or Additional_Check = Record_Array(1, 7) Then
Row_Counter = Row_Counter + 1
ReDim Preserve Tmp(1 To Number_Of_Columns, 1 To Row_Counter)
For j = 1 To Number_Of_Columns
Select Case j
Case 3, 4, 9: Tmp(j, Row_Counter) = CLng(Row_Array(i, j))
Case Else: Tmp(j, Row_Counter) = Row_Array(i, j)
End Select
Next j
End If
End If
End If
Next i
End With

If Row_Counter > 0 Then
With ThisWorkbook.Worksheets("supply filtered data")
User_Input = MsgBox("Do you wish to APPEND to earlier data ( Y/N ) ; NO means earlier data will be overwritten !", vbYesNo)
If User_Input = vbYes Then
Set WherePaste = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
Else
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastLig >= 2 Then .Rows("2:" & LastLig).Clear
Set WherePaste = .Range("A2")
End If
End With

With WherePaste
.Resize(Row_Counter, Number_Of_Columns).Value = Application.Transpose(Tmp)
.Offset(0, 2).Resize(Row_Counter, 2).NumberFormat = "mm/dd/yyyy"    'columns 3,4 and 9 are dates
.Offset(0, 8).Resize(Row_Counter, 1).NumberFormat = "mm/dd/yyyy"
End With
Set WherePaste = Nothing
MsgBox "Procedure Over , " & Row_Counter & " records copied / pasted"
Else
MsgBox "Nothing copied / pasted"
End If
End Sub
[/pre]
 
Hi Mercatog,


Thanks this approach work. Just a minor change needed. i tried but not get success. "in columns 3,4 and 9 only 3 & 9 are dates and 4 is just simple number or string" Please help.

[pre]
Code:
Public Sub Filter_Supply_Data()
Dim LastLig As Long, Number_Of_Rows As Long, Row_Counter As Long, i As Long, Check_Date As Date
Dim Row_Array As Variant, Record_Array As Variant, Tmp() As Variant
Dim Customer_Name As String, Additional_Check As String
Dim Number_Of_Columns As Integer, j As Integer
Dim WherePaste As Range
Dim User_Input As Byte

Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("Supply Data").Range("Supply_Data")
Number_Of_Rows = .Rows.Count
Record_Array = ThisWorkbook.Worksheets("Dashboard").Range("A21:G21").Value
Number_Of_Columns = .Columns.Count
Row_Array = .Offset(1, 0).Resize(Number_Of_Rows - 1, Number_Of_Columns).Value

For i = 1 To Number_Of_Rows - 1
Application.StatusBar = Format(i / Number_Of_Rows, "0%")
Customer_Name = Row_Array(i, 1)
Check_Date = CDbl(Row_Array(i, 9))
Additional_Check = Row_Array(i, 11) 

If Customer_Name = Record_Array(1, 1) Then
If Check_Date >= CDbl(Record_Array(1, 3)) And Check_Date <= CDbl(Record_Array(1, 5)) Then
If Record_Array(1, 7) = "" Or Left(Additional_Check, 10) = Record_Array(1, 7) Then
Row_Counter = Row_Counter + 1
ReDim Preserve Tmp(1 To Number_Of_Columns, 1 To Row_Counter)
For j = 1 To Number_Of_Columns
Select Case j
Case 3, 4, 9: Tmp(j, Row_Counter) = CDbl(Row_Array(i, j))
Case Else: Tmp(j, Row_Counter) = Row_Array(i, j)
Tmp(j, Row_Counter) = Row_Array(i, j)
End Select
Next j
End If
End If
End If
Next i
End With

If Row_Counter > 0 Then
With ThisWorkbook.Worksheets("Filtered Supply Data")
User_Input = MsgBox("Do you wish to APPEND to earlier data ( Y/N ) ; NO means earlier data will be overwritten !", vbYesNo)
If User_Input = vbYes Then
Set WherePaste = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
Else
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastLig >= 2 Then .Rows("2:" & LastLig).ClearContents
Set WherePaste = .Range("A2")
End If
End With
With WherePaste
.Resize(Row_Counter, Number_Of_Columns).Value = Application.Transpose(Tmp)
.Offset(0, 2).Resize(Row_Counter, 2).NumberFormat = "mm/dd/yyyy"    'columns 3,4 and 9 are dates
.Offset(0, 8).Resize(Row_Counter, 1).NumberFormat = "mm/dd/yyyy"
End With
Set WherePaste = Nothing
MsgBox "Procedure Over , " & Row_Counter & " records copied / pasted"
Else
MsgBox "Nothing copied / pasted"
End If
Application.StatusBar = False
End Sub
[/pre]
 
Hi Experts,


Please help me me understand this piece of code. there is something I am missing in this. my 4th coloum is being formatted as date while I need not to format it.

---------------------------------------------------------------

[pre]
Code:
For j = 1 To Number_Of_Columns
Select Case j
Case 3, 4, 9: Tmp(j, Row_Counter) = CDbl(Row_Array(i, j))
Case Else: Tmp(j, Row_Counter) = Row_Array(i, j)
Tmp(j, Row_Counter) = Row_Array(i, j)
End Select
Next j
----------------------------------------------------------

With WherePaste
.Resize(Row_Counter, Number_Of_Columns).Value = Application.Transpose(Tmp)
.Offset(0, 2).Resize(Row_Counter, 2).NumberFormat = "mm/dd/yyyy"    'columns 3,4 and 9 are dates
.Offset(0, 8).Resize(Row_Counter, 1).NumberFormat = "mm/dd/yyyy"
End With
[/pre]
Regards,
 
Hi, I thought that you can adapte to your file

Change lines like this

Code:
Case 3, 9: Tmp(j, Row_Counter) = CDbl(Row_Array(i, j)) 


Then to format onlu column 3 and 9

[pre][code]'....
.Offset(0, 2).Resize(Row_Counter, 1).NumberFormat = "mm/dd/yyyy"    'columns 3 and 9 are dates
.Offset(0, 8).Resize(Row_Counter, 1).NumberFormat = "mm/dd/yyyy"
Regards


EDIT

I see that you add a line in the part of Select Case! That's wrong

Here the entire code

Public Sub Filter_Supply_Data()
Dim LastLig As Long, Number_Of_Rows As Long, Row_Counter As Long, i As Long
Dim Row_Array As Variant, Record_Array As Variant, Tmp() As Variant
Dim Customer_Name As String, Additional_Check As String
Dim Number_Of_Columns As Integer, j As Integer
Dim Check_Date As Double
Dim WherePaste As Range
Dim User_Input As Byte

With ThisWorkbook.Worksheets("Supply Data").Range("Supply_Data")
Number_Of_Rows = .Rows.Count
Record_Array = ThisWorkbook.Worksheets("Dashboard").Range("A21:G21").Value
Number_Of_Columns = .Columns.Count
Row_Array = .Offset(1, 0).Resize(Number_Of_Rows - 1, Number_Of_Columns).Value

For i = 1 To Number_Of_Rows - 1
Application.StatusBar = Format(i / Number_Of_Rows, "0%")
Customer_Name = Row_Array(i, 1)
Check_Date = CDbl(Row_Array(i, 9))
Additional_Check = Row_Array(i, 11)

If Customer_Name = Record_Array(1, 1) Then
If Check_Date >= CDbl(Record_Array(1, 3)) And Check_Date <= CDbl(Record_Array(1, 5)) Then
If Record_Array(1, 7) = "" Or Left(Additional_Check, 10) = Record_Array(1, 7) Then
Row_Counter = Row_Counter + 1
ReDim Preserve Tmp(1 To Number_Of_Columns, 1 To Row_Counter)
For j = 1 To Number_Of_Columns
Select Case j
Case 3, 4, 9
Tmp(j, Row_Counter) = CDbl(Row_Array(i, j))
Case Else
Tmp(j, Row_Counter) = Row_Array(i, j)
End Select
Next j
End If
End If
End If
Next i
End With

If Row_Counter > 0 Then
With ThisWorkbook.Worksheets("Filtered Supply Data")
User_Input = MsgBox("Do you wish to APPEND to earlier data ( Y/N ) ; NO means earlier data will be overwritten !", vbYesNo)
If User_Input = vbYes Then
Set WherePaste = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
Else
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastLig >= 2 Then .Rows("2:" & LastLig).ClearContents
Set WherePaste = .Range("A2")
End If
End With
With WherePaste
.Resize(Row_Counter, Number_Of_Columns).Value = Application.Transpose(Tmp)
.Offset(0, 2).Resize(Row_Counter, 1).NumberFormat = "mm/dd/yyyy" 'column 3 is date
.Offset(0, 8).Resize(Row_Counter, 1).NumberFormat = "mm/dd/yyyy" 'column 9 is date
End With
Set WherePaste = Nothing
MsgBox "Procedure Over , " & Row_Counter & " records copied / pasted"
Else
MsgBox "Nothing copied / pasted"
End If
Application.StatusBar = False
End Sub[/code][/pre]
 
Thanks Mercatog,


Issue resolved. Somehow even after suggested change it was getting formatted as date only but moving ahead on your approach i just add one more line and that solved my issue.


Code:
.Offset(0, 3).Resize(Row_Counter, 1).NumberFormat = "General"


I am thankful to you.


Regards,
 
Back
Top