Converte Data in colonna unica.

[Gianca532011]

Ciao a tutti e buone feste.
Ho questa macro che ricerca in colonna R ( copiate da col. I ) le date che hanno formato a due cifre : 34, 45, 89. Ovviamente trattandosi di dati di borsa NON possono essere 1934, 1945,1989 come talvolta capita nella conversione, anche se usato il formato gg/mm/aaaa. Quindi ho costruito la macro sotto allegata con la quale a tutti i dati < 1/1/2000 aggiungo 100 anni secchi con l'aiuto di una formula inserita in colonna T.
La macro funziona, ma avendola realizzata passo passo alla fine occupo tre colonne di appoggio. Vorrei quindi modificare la macro , inserendo nel VBA l'equivalente della formula e fare tutto nella stessa colonna (I di Imola ) nella quale arrivano i dati primari in formato stringa.

Codice: Seleziona tutto

Option Explicit

Sub daString_a_Data()
    Dim k As Long, uR As Long, R
    Dim sh1 As Worksheet
    Application.ScreenUpdating = False
    Set sh1 = ThisWorkbook.Sheets("Isin")
    sh1.Activate
    uR = Cells(Rows.Count, "I").End(xlUp).Row
    For k = 2 To uR
        ' scrive la data in una colonna di appoggio
        On Error Resume Next  ' controllo errore nel caso ci sia una scritta tipo perpetuo.
        Cells(k, 18).Value = CDate(Cells(k, 9).Value)
        On Error GoTo 0
    Next k
   
'---------------------------------
    ' ricerca date anomale riportate come es 1934  e le  corregge a 2034 aggiungendo 100 anni
    Dim t As Date, Ing As Integer
    t = "1/1/2020"
    For Ing = 2 To uR
        If Range("R" & Ing).Value < t Then
            Range("R" & Ing).Copy
            Range("S" & Ing).PasteSpecial
        End If
'-------------------------------------------------------------------------------
 'Nota bene in T da 2 a1000 inserire questa formula  che  controlla e modifica il dato di colonna S :
 ' =SE($S2<>"";DATA(ANNO($S2)+100;MESE($S2);GIORNO($S2));"")
 'formattare la colonna T come "data"
   '-------------------------------
    If Range("T" & Ing).Value <> "" Then
            Range("T" & Ing).Copy
            Range("R" & Ing).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
       Next
 
       'copia nella colonna effettiva e cancella l'appoggio
    R = ActiveSheet.Range("R2")
    ActiveSheet.Range("R2:R" & uR).Copy Destination:=sh1.Range("I2")
    Range("I2:I" & uR).NumberFormat = "dd/mm/yyyy"
  Range("R2:S" & uR).Clear
    Set sh1 = Nothing
End Sub



[Anthony47]

Non ho voluto decodificare tutto quello che fa la macro, ma prova se questa versione fa la conversione che dici:

Codice: Seleziona tutto

Sub daString_a_Data()
Dim k As Long, uR As Long
Dim oArr()
'
Sheets("Isin").Activate
uR = Cells(Rows.Count, "I").End(xlUp).Row
ReDim oArr(2 To uR, 1 To 1)
For k = 2 To uR
    oArr(k, 1) = CDate(Cells(k, 9))
    If oArr(k, 1) < CDate("01/01/2000") Then
        oArr(k, 1) = Application.WorksheetFunction.EDate(oArr(k, 1), 1200)
    End If
Next k
Range("I2:I" & uR).NumberFormat = "dd/mm/yyyy"
Range("I2:I" & uR).Value = oArr
End Sub


[Gianca532011]

Grazie Anthony , sembra funzionare bene , poi la controllo meglio con un elenco esteso.
Comunque , se posso, mi spieghi quesata riga che è il cuore del sistema ?

Codice: Seleziona tutto

 oArr(k, 1) = Application.WorksheetFunction.EDate(oArr(k, 1), 1200)

e poi il riferimento alla colonna 1 come si spiega ?
grazie.

[Anthony47]

EDate e' l'quivalente vba della funzione Excel DATA.MESE, e 1200 corrisponde a 12 (mesi) * 100 (anni)

OArr e' una matrice in memoria in cui scrivo le date, ed eventualmente le correggo con l'istruzione che hai evidenziato; trattandosi di una matrice di N righe * 1 colonna il suo contenuto e' indirizzato con oArr(k,1), riga k e colonna 1.

A completamento del ciclo For K /Next K il contenuto di oArr e' scritto sul foglio di lavoro

Ciao

[Gianca532011]

Ho un altro problema con le date , aggiungo qui sotto perchè il problema è quasi simile.
Dunque da un sito scarico un file CSV che poi importo nel mio file. Ora di questi dati vorrei ricavare un grafico, ma vorrei che i dati avessero una sequenza temporale dal piu vecchio al piu recente , mentre i dati vengono scaricati con in testa il piu recente, quindi nell'ordine inverso rispetto a quello che mi è necessario per il grafico. Che fare ? Ho provato a usare il solito Dati -Ordina ma i risultati sono pessimi , quindi ho tentato di convertire la data a seriale e solo dopo fare l'ordinamento per serie: dal piu vecchio al piu recente. Ma qui mi sono bloccato.
Ho pure tentato di aggirare l'ostacolo agendo sul grafico, ovvero facendogli prendere i dati dal basso annzichè dall'alto ma anche qui ho fallito miseramente .
La macro sotto è la clonazione della tua ma anche questa non funzia. ????

Codice: Seleziona tutto


Sub ConvertiInNumero()
    Dim i As Long
    Dim uR As Long
    uR = Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To uR
        If Cells(i, 2) <> "" Then
            Cells(i, 2) = CDate(Cells(i, 2))
        End If
    Next
End Sub


allego file CSV di esempio e file con macro.

https://ufile.io/f/96e64

[Gianca532011]

Come non detto , me la sono cavata con questa macro che inverte tutti i dati, in cui l'intervallo (B2:H & ur ) è l'intervallo dati.

Codice: Seleziona tutto

Sub FlipColumns()

Dim Rng As Range, uR As Integer
Dim WorkRng As Range
Dim Arr As Variant
Dim i As Integer, j As Integer, k As Integer
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set ws = ActiveWorkbook.Sheets("Grafico")
uR = ws.Cells(Rows.Count, 2).End(xlUp).Row
Set WorkRng = ws.Range("B2:H" & uR) 'Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Arr = WorkRng.Formula
For j = 1 To UBound(Arr, 2)
    k = UBound(Arr, 1)
    For i = 1 To UBound(Arr, 1) / 2
        xTemp = Arr(i, j)
        Arr(i, j) = Arr(k, j)
        Arr(k, j) = xTemp
        k = k - 1
    Next
Next
WorkRng.Formula = Arr
End Sub


[Anthony47]

Se funziona va bene così...
Tuttavia invece di aggiungere macro su macro il mio suggerimento e' di importare correttamente il file csv; ad esempio con questa macro:

Codice: Seleziona tutto

Sub ImportCSVFile2()
Dim WArr, I As Long, J As Long
'
  Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim FileName As String
'   Const strPath As String = "C:\Users\Giancarlo\Downloads\"
    Set ws = ActiveWorkbook.Sheets("Grafico")    ' change to suit
' ChDir strPath
ws.Select
    ws.Range("B:H").ClearContents
    FileName = Application.GetOpenFilename("Text Files (*.csv),*.csv", , _
               "Please select source file")

    With ws.QueryTables.Add(Connection:="TEXT;" & FileName, _
                            Destination:=ws.Range("B1"))       ' change to suit
        .Name = "FTSE MIB Dati Storici (6)"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(4, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Columns("C:F").Select
    Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'
    WArr = Range(Range("B1"), Range("B1").End(xlDown)).Resize(, 7)
    On Error Resume Next
    For I = 1 To UBound(WArr)
        For J = 1 To UBound(WArr, 2)
            WArr(I, J) = WArr(I, J) * 1
        Next J
    Next I
    Range("B:H").ClearContents
    Range("B1").Resize(UBound(WArr), UBound(WArr, 2)).Value = WArr
Range("B1").Select
End Sub


Questa ti importa il csv, impostando col 1 come "data" e le altre colonne come numero.

A questo punto puoi creare il tuo grafico; se formatti l'asse X come "Asse Testo" l'ordine sara' dal piu' recente al piu' vecchio; se invece formatti come "Asse Data" allora l'ordine di default sara' dal piu' vecchio al piu' recente.

Ciao

[Gianca532011]

Grazie, funziona tutto eccetto questo codice sotto che ho rimosso, perchè i dati da C-F sono già in formato numero con due decimali. Il problema era tutto nel formato data 05.01.2023 che è diventato 05/01/2023 e anche il grafico è andato a posto senza nulla fare.
Ps il codice dava errore

Codice: Seleziona tutto

'Columns("C:F").Select
   ' Selection.Replace What:=".", Replacement:=" ", LookAt:=xlPart, _
    '   SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
     '   ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'

immagino che l'attribuzione dei tipi di formato per le colonne dati tu l'abbia fatta con questa istruzione ? Se si dove trovo i riferimenti ?

Codice: Seleziona tutto

.TextFileColumnDataTypes = Array(4, 1, 1, 1, 1, 1, 1)

[Anthony47]

immagino che l'attribuzione dei tipi di formato per le colonne dati tu l'abbia fatta con questa istruzione ? Se si dove trovo i riferimenti ?

Codice: Seleziona tutto

    .TextFileColumnDataTypes = Array(4, 1, 1, 1, 1, 1, 1)


Il codice proviene da una macro autoregistrata; per la teoria:
https://learn.microsoft.com/it-it/offic ... ndatatypes
https://learn.microsoft.com/it-it/offic ... mndatatype

Ciao