Datumnotatie in Amerikaans door VBA

Question

Datumnotatie in Amerikaans door VBA

Anoniem

Hallo,

Ik gebruik een code in VBA waardoor die cellen overneemt uit een andere tabblad, mocht de vergelijking ergens op uitvallen.

De cellen mbt datums doet die echter omzetten naar een Amerikaans format MM/DD/YYYY.

Ik weet niet hoe ik dit kan oplossen. Onderstaande is de code (die ik niet zelf gemaakt heb):

Sub Results1()

Dim ws As Worksheet, ws2 As Worksheet

Set ws = ThisWorkbook.Worksheets("XW")

Set ws2 = ThisWorkbook.Worksheets("ZL")

Dim arr, arr2

arr = Array("D", "E", "L", "O", "R", "S", "T", "U", "V", "W", "X", "AA", "AB")

arr1 = Array("D", "E", "L", "O", "R", "S", "T", "X")

arr2 = Array("W", "B", "J", "K", "L", "M", "N", "G")

Dim datAarr()

tCol = UBound(arr) + UBound(arr1) + 1

ReDim datAarr(0 To tCol, 0)

rCount = 0

With ws

On Error Resume Next

.ShowAllData

On Error GoTo 0

sRow = 2

eRow = .Range("A" & ws.Rows.Count).End(xlUp).Row

For cRow = sRow To eRow 

    If .Range("C" & cRow) = 180 And UCase(.Range("V" & cRow)) = "ZIN" Then 

        tValue = .Range("D" & cRow) 

        For j = 0 To UBound(arr) 

         datAarr(j, rCount) = ws.Range(arr(j) & cRow) 

        Next 

        If Application.WorksheetFunction.CountIf(ws2.Range("W:W"), tValue) Then 

            tMatch = Application.WorksheetFunction.Match(tValue, ws2.Range("W:W"), 0) 

            For j = 0 To UBound(arr1) 

                If ws.Range(arr1(j) & cRow) &lt;&gt; ws2.Range(arr2(j) & tMatch) Then 

                    devCount = devCount + 1 

                    datAarr(UBound(arr) + 1 + j, rCount) = ws2.Range(arr2(j) & tMatch) 

                End If 

            Next 

            If devCount &gt; 0 Then 

                rCount = rCount + 1 

                ReDim Preserve datAarr(tCol, rCount) 

                devCount = 0 

            End If 

                Else 

            datAarr(UBound(arr) + 1, rCount) = "False" 

            rCount = rCount + 1 

            ReDim Preserve datAarr(tCol, rCount) 

        End If 

    End If 

Next

End With

Range("A3").Resize(Rows.Count - 2, Columns.Count) = ""

Range("A3").Resize(rCount, tCol + 1) = Application.Transpose(datAarr)

End Sub

Vergrendelde vraag. Deze vraag is gemigreerd vanuit de Microsoft Ondersteuning-community. U kunt met een stem aangeven of de inhoud nuttig is, maar u kunt geen opmerkingen of antwoorden toevoegen of de vraag volgen.

0 opmerkingen

6 antwoorden

Answer 1

Anoniem

I'm getting a new error. Translated it say: "Compile error: Can't change the data type of matrixparts(??)

Looks like i cant attach the file in the reply.

0 opmerkingen

Answer 2

Hi RJEEP!

Thank you for the feedback

Please try this: Sub Results1() Dim ws As Worksheet, ws2 As Worksheet Set ws = ThisWorkbook.Worksheets("XW") Set ws2 = ThisWorkbook.Worksheets("ZL") Dim arr, arr2 Dim arr1, datAarr() arr = Array("D", "E", "L", "O", "R", "S", "T", "U", "V", "W", "X", "AA", "AB") arr1 = Array("D", "E", "L", "O", "R", "S", "T", "X") arr2 = Array("W", "B", "J", "K", "L", "M", "N", "G") Dim rCount As Long, devCount As Long Dim sRow As Long, eRow As Long, cRow As Long, tMatch As Variant Dim tValue As Variant, tCol As Long

tCol = UBound(arr) + UBound(arr1) + 1 ReDim datAarr(0 To tCol, 0 To 0) As String rCount = 0

With ws On Error Resume Next . ShowAllData On Error GoTo 0 sRow = 2 eRow = . Range("A" & . Rows.Count). End(xlUp). Row For cRow = sRow To eRow If . Range("C" & cRow) = 180 And UCase(. Range("V" & cRow)) = "ZIN" Then tValue = . Range("D" & cRow) For j = 0 To UBound(arr) datAarr(j, rCount) = Format(ws. Range(arr(j) & cRow). Value, "dd-mm-yyyy") Next If Application.WorksheetFunction.CountIf(ws2. Range("W:W"), tValue) Then tMatch = Application.WorksheetFunction.Match(tValue, ws2. Range("W:W"), 0) For j = 0 To UBound(arr1) If ws. Range(arr1(j) & cRow) <> ws2. Range(arr2(j) & tMatch) Then devCount = devCount + 1 datAarr(UBound(arr) + 1 + j, rCount) = ws2. Range(arr2(j) & tMatch) End If Next If devCount > 0 Then rCount = rCount + 1 ReDim Preserve datAarr(tCol, rCount) As String devCount = 0 End If Else datAarr(UBound(arr) + 1, rCount) = "False" rCount = rCount + 1 ReDim Preserve datAarr(tCol, rCount) As String End If End If Next End With

Range("A3"). Resize(Rows.Count - 2

Best Regards, Shakiru

Answer 3

Hi Shakiru,

Thanks for your reply.

If i change the code to the one below, I get an OVERFLOW error:

Sub Results1()

Dim ws As Worksheet, ws2 As Worksheet

Set ws = ThisWorkbook.Worksheets("XW")

Set ws2 = ThisWorkbook.Worksheets("ZL")

Dim arr, arr2

arr = Array("D", "E", "L", "O", "R", "S", "T", "U", "V", "W", "X", "AA", "AB")

arr1 = Array("D", "E", "L", "O", "R", "S", "T", "X")

arr2 = Array("W", "B", "J", "K", "L", "M", "N", "G")

Dim datAarr()

tCol = UBound(arr) + UBound(arr1) + 1

ReDim datAarr(0 To tCol, 0)

rCount = 0

With ws

On Error Resume Next

.ShowAllData

On Error GoTo 0

sRow = 2

eRow = .Range("A" & ws.Rows.Count).End(xlUp).Row

For cRow = sRow To eRow 

    If .Range("C" & cRow) = 180 And UCase(.Range("V" & cRow)) = "ZIN" Then 

        tValue = .Range("D" & cRow) 

        For j = 0 To UBound(arr) 

         **datAarr(j, rCount) = Format(ws.Range(arr(j) & cRow).Value, "dd-mm-yyyy")** 

        Next 

        If Application.WorksheetFunction.CountIf(ws2.Range("W:W"), tValue) Then 

            tMatch = Application.WorksheetFunction.Match(tValue, ws2.Range("W:W"), 0) 

            For j = 0 To UBound(arr1) 

                If ws.Range(arr1(j) & cRow) &lt;&gt; ws2.Range(arr2(j) & tMatch) Then 

                    devCount = devCount + 1 

                    datAarr(UBound(arr) + 1 + j, rCount) = ws2.Range(arr2(j) & tMatch) 

                End If 

            Next 

            If devCount &gt; 0 Then 

                rCount = rCount + 1 

                ReDim Preserve datAarr(tCol, rCount) 

                devCount = 0 

            End If 

                Else 

            datAarr(UBound(arr) + 1, rCount) = "False" 

            rCount = rCount + 1 

            ReDim Preserve datAarr(tCol, rCount) 

        End If 

    End If 

Next

End With

Range("A3").Resize(Rows.Count - 2, Columns.Count) = ""

Range("A3").Resize(rCount, tCol + 1) = Application.Transpose(datAarr)

End Sub

Answer 4

Ik gebruik een code in VBA waardoor die cellen overneemt uit een andere tabblad,

mocht de vergelijking ergens op uitvallen.

Wie begrijpt waar dat op slaat, is een een knappe man/vrouw.

De cellen mbt datums doet die echter omzetten naar een Amerikaans format MM/DD/YYYY.

Ik weet niet hoe ik dit kan oplossen. Onderstaande is de code (die ik niet zelf gemaakt heb).

Die code heeft toch niet betrekking op het omzetten van datums?

Een datum in Nederlands formaat kun je eenvoudig via de celeigenchappen omzetten naar Amerikaans formaat. Als je dat beslist via vba wil doen, dan kun je gebruiken (als je de datum in A1 wil omzetten):

Range("A1").NumberFormat = "mm/dd/yyyy"

Answer 5

Hi RJEEP!

You can modify the code to format the date in the desired format before inserting it into the datAarr array.

Here's an example of how to format a date in VBA:

Format(ws. Range(arr(j) & cRow). Value, "dd/mm/yyyy") This code formats the date in the format dd/mm/yyyy. You can modify it to your desired format.

You can replace this line of code in your existing code:

datAarr(j, rCount) = ws. Range(arr(j) & cRow)

with this line of code:

datAarr(j, rCount) = Format(ws. Range(arr(j) & cRow). Value, "dd/mm/yyyy")

or this: datAarr(j, rCount) = Format(ws. Range(arr(j) & cRow). Value, "dd-mm-yyyy") (relative to Dutch's Date format)

Kindly let me know, if you require additional assistance, I will be glad to help further.

Best Regards, Shakiru

Delen via

Datumnotatie in Amerikaans door VBA

6 antwoorden