Importer des données texte dans un classeur onglet par onglet (sheet cachée)

Commenter

Contenu du snippet

Public Sub RechercheDossier()
Dim strSourceDossier As String
Dim strSourceFichier As String
Dim strDestDossier As String
Dim strDestFichier As String
Dim strDestSheet As String
Dim blnCache As Boolean
Dim ChFunction As Boolean
Dim intStartRow As Integer
Dim Ws As Worksheet
Dim DossierSource As String
Dim DossierDest As String
Dim ChCelRec As String

Set Ws = ActiveWorkbook.Worksheets("Sheet1")
intStartRow = 3
strSourceDossier = ""
strSourceFichier = ""
strDestDossier = ""
strDestFichier = ""
strDestSheet = ""
blnCache = False
ChFunction = False
ChCelRec = ""

'Read the table
Do While strSourceDossier <> "STOP"


strSourceDossier = Ws.Cells(intStartRow, 1)
strSourceFichier = Ws.Cells(intStartRow, 2)
strDestDossier = Ws.Cells(intStartRow, 3)
strDestFichier = Ws.Cells(intStartRow, 4)
strDestSheet = Ws.Cells(intStartRow, 5)
blnCache = Ws.Cells(intStartRow, 6)
ChFunction = Ws.Cells(intStartRow, 7)
ChCelRec = Ws.Cells(intStartRow, 8)

'enregistrement à la fin du dossier traité
If strSourceDossier = "Fin de dossier Destination" Then
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWorkbook.Close
intStartRow = intStartRow + 1
strSourceDossier = Ws.Cells(intStartRow, 1)
strSourceFichier = Ws.Cells(intStartRow, 2)
strDestDossier = Ws.Cells(intStartRow, 3)
strDestFichier = Ws.Cells(intStartRow, 4)
strDestSheet = Ws.Cells(intStartRow, 5)
blnCache = Ws.Cells(intStartRow, 6)
ChFunction = Ws.Cells(intStartRow, 7)
ChCelRec = Ws.Cells(intStartRow, 8)
End If

If strSourceDossier = "STOP" Then
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWorkbook.Close
End If

'concaténation
DossierSource = strSourceDossier & "\" & strSourceFichier
DossierDest = strDestDossier & "\" & strDestFichier

'véfier si le dossier est ouvert
verifDossierOpen DossierDest

'vérifier si la feuille est cachée ou pas.
FeuilleCache blnCache, strDestSheet

'Application.CutCopyMode = False
Sheets(strDestSheet).Select
If ChCelRec <> "A5" Then
'appel fonction import
If ChFunction = True Then
ImportEandisOpsplitsing DossierSource, DossierDest
Else
ImportTxtTabDate DossierSource, DossierDest
End If
Else
ImportCellA5 DossierSource, DossierDest
End If

If blnCache = True Then
Sheets(strDestSheet).Visible = False
End If

intStartRow = intStartRow + 1
Loop

End Sub
Public Sub verifDossierOpen(ByVal DossierDest As String)
Dim OpenDos As Integer
OpenDos = 0
On Error Resume Next
For t = 1 To Workbooks.Count
If Workbooks(t).Name = DossierDest Then OpenDos = 1
Next t
If OpenDos = 0 Then
Workbooks.Open Filename:=DossierDest 'ouvrir le classeur
Application.CutCopyMode = False
End If

End Sub

Public Sub FeuilleCache(ByVal blnCache As Boolean, ByVal strDestSheet As String)
If blnCache = True Then
Sheets(strDestSheet).Visible = True
ActiveWindow.WindowState = xlNormal
End If
End Sub

Public Sub ImportTxtTabDate(ByVal DossierSource As String, _
ByVal DossierDest As String)

Dim Source As String, Destination As String
Dim FileNumber As Integer, cpt As Integer
Dim Chaine As String
Dim i As Integer, Pos As Integer, NbCol As Integer
Dim ar() As String
Dim datday As Date
Dim datPrevDay As Date
Dim intStartRow As Integer


Source = DossierSource
Destination = DossierDest
FileNumber = FreeFile '1er numero libre

Open Source For Input As #FileNumber 'ouverture en lecture
Line Input #FileNumber, Chaine 'lit la ligne entiere et l'attribue à la variable
ar() = Split(Chaine, vbTab) 'retourne les elements separer pas Tab
NbCol = UBound(ar()) 'retoourne la dimension des colonnes
intStartRow = 4 'depart de l'écriture
cpt = intStartRow
' Open Source For Input As #FileNumber

Do While Not EOF(FileNumber)
ar() = Split(Chaine, vbTab)

If cpt - intStartRow > 0 Then
datday = ar(0)

If datPrevDay < #1/1/1900# Then
datPrevDay = DateAdd("d", -1, datday)
End If

For i = 0 To NbCol
Cells(cpt, i + 1).ClearContents
Pos = InStr(ar(i), ".")

If IsNumeric(ar(i)) Then
Cells(cpt, i + 1) = CDbl(ar(i))
ElseIf Pos > 0 Then
Cells(cpt, i + 1) = ar(i)
ElseIf IsDate(ar(i)) Then
Cells(cpt, i + 1) = CDate(ar(i))
End If
Next
datPrevDay = Cells(cpt, 1)
Line Input #FileNumber, Chaine
cpt = cpt + 1
Else
'total
For i = 0 To NbCol
Cells(cpt, i + 1).ClearContents
Pos = InStr(ar(i), ".")

If IsNumeric(ar(i)) Then
Cells(cpt, i + 1) = CDbl(ar(i))
ElseIf Pos > 0 Then
Cells(cpt, i + 1) = ar(i)
ElseIf IsDate(ar(i)) Then
Cells(cpt, i + 1) = CDate(ar(i))

ElseIf (Pos = 0) Then
Cells(cpt, i + 1) = UCase(ar(i))
End If
Next


cpt = cpt + 1
Line Input #FileNumber, Chaine

End If

Loop

Close #FileNumber

Cells(1, NbCol + 2).Select
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.