1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
Sub import_real()
Application.ScreenUpdating = False 'the screen is not updating during the function
On Error GoTo ErrorCode 'if ther is an error, the programme execute the code in "ErrorCode" below
Dim FileIndex As Integer 'FileIndex is an Integer
Dim LineContent As String 'LineContent is a String
Dim I As Integer 'I is an Integer
Dim J As Integer 'J is an Integer
Dim table() As String 'table1() is a table of String
Dim part_a As String 'part_a is a String
Dim part_b As String 'part_b is a String
Dim switch As String 'switch is a String
Dim char As String 'char is a String
Dim color
Dim group As String 'group is a String
Dim Case_Id As String 'Case_Id is a String
Dim nb As Integer 'nb is an Integer
Dim name As String 'name is a String
Dim A As String 'A is a String
Dim B As String 'B is a String
Dim C As String 'C is a String
FileIndex = FreeFile()
Sheets("Parameters").Activate 'Activate the "Parameters" sheet on the excel doc
nb = Application.CountA([A:A]) 'Count the number of filled case in the collumn A
For J = 2 To nb 'Execute a loop for each filled case in the collumn A
A = "A" & J
B = "B" & J
C = "C" & J
name = Sheets("Parameters").Range(A).Value 'name take the value of the case A corresponding to the value of J
I = 2
Open name For Input As #FileIndex 'open the file corresponding to "name"
group = Sheets("Parameters").Range(C).Value 'group take the value of the case C corresponding to the value of J
Case_Id = "J" & Application.Match(group, Sheets("Parameters").Range("J:J"), 0) 'Find the case in the collumn J where there is the word corresponding to "group"
color = Sheets("Parameters").Range(Case_Id).Interior.color 'color take the value of the "Case_Id" color
Sheets.Add After:=ActiveSheet 'open a new sheet in Excel
ActiveSheet.name = Sheets("Parameters").Range(B).Value 'rename the sheet with the name of the file
ActiveSheet.Tab.color = color 'color the sheet with "color"
Call design 'call design funtion below
While Not EOF(FileIndex) 'While there is still a line in the file execute the code below
Line Input #FileIndex, LineContent ' read the file line by line: LineContent take the content of the active line
cells(I, 1).Value = LineContent 'the case (i,1) in the excel doc take the value of LineContent
switch = cells(I, 1).Value 'switch take the value of the cells(I,1)
If Mid(switch, 1, 3) = "" Then 'If there is the 3 characteres at the start
cells(I, 1).Value = Replace(switch, Left(switch, 3), "") 'delete it
End If
switch = cells(I, 1).Value 'switch take the value of cells(i,1)
char = Left(switch, 1) 'char take the first charactere of LineContent
If char <> "#" Then
table = split(LineContent, "=") 'we cut the line in to part when ther is an "=" in the line and we place the to part of the line in the table
part_a = table(0) 'part_a take the value of the first case of the table (the first part of the line)
part_b = table(1) 'part_b take the value of the second case of the table (the second part of the line)
cells(I, 1).Value = part_a 'the case (i,1) in the excel doc take the value of part_a
cells(I, 2).Value = part_b 'the case (i,2) in the excel doc take the value of part_b
End If
I = I + 1
Wend
Call replace_char
Close #FileIndex 'close the file wich is open
Next
Sheets("Action").Activate 'open the "Action" sheet
Application.ScreenUpdating = True 'update the screen
MsgBox "Import done" 'display a message if the import was done
Exit Sub
ErrorCode: 'the code below is executing if there is a probleme during the function
MsgBox "An error has occured..." 'Display an error message
Application.ScreenUpdating = True 'update the screen
End Sub
Sub design()
Range("A1").Value = "Key Word" 'The case "A1" take the value "Key Word"
Range("A1").Font.Italic = True 'apply italic on the case "A1"
Range("A1").Font.Bold = True 'apply bold on the case "A1"
Range("B1").Value = "Meaning" 'The case "B1" take the value "Meaning"
Range("B1").Font.Italic = True 'apply italic on the case "B1"
Range("B1").Font.Bold = True 'apply bold on the case "B1"
Columns("A:A").ColumnWidth = 56.57 'Change the width of the column A
Columns("B:B").ColumnWidth = 48.29 'Change the width of the column B
End Sub
Sub replace_char()
ReDim A_Remplacer(0 To 32)
ReDim Remplacants(0 To 32)
Dim I As Byte
A_Remplacer = Array("ß", "ï", "ó", "Î", "ä", "ü", "ö", "î", "é", "→", "Ü", "ù", "â", "è", "à ", "’", "€", "®", "Ø", "°", "ç", "ô", _
"«", "»", "û", "ê", "Ã*", "ú", "á", "ñ", "¿", "Ú", "Ã")
Remplacants = Array("ß", "ï", "ó", "Î", "ä", "ü", "ö", "î", "é", Chr(26), "Ü", "û", "â", "è", "à", "'", "€", "®", "Ø", "°", "ç", "ô", _
Chr(34), Chr(34), "û", "ê", "í", "ú", "á", "ñ", "¿", "Ú", "Í")
For I = 0 To 32
cells.Replace What:=A_Remplacer(I), Replacement:=Remplacants(I), LookAt:=xlPart
Next I
End Sub |
Problème d'import de caractères chinois
Répondre avec citation
c'est toujours apprécié...
pour clore cette discussion.
Partager