Código de Visual Basic para Aplicaciones - Acceder desde Excel a los registros de una tabla de una base de datos en un servidor remoto de MySQL

Requerimientos

Excel e instalar un driver OBDC (hay instrucciones para hacerlo) para acceder al MySQL

1.0
estrellaestrellaestrellaestrellaestrella(2)

Actualizado el 30 de Noviembre del 2020 (Publicado el 23 de Noviembre del 2020)gráfica de visualizaciones de la versión: 1.0
851 visualizaciones desde el 23 de Noviembre del 2020
estrellaestrellaestrellaestrellaestrella
estrellaestrellaestrellaestrella
estrellaestrellaestrella
estrellaestrella
estrella

Pantalla inicial con los datos del servidor remoto, pulsar el botón ACCESS para el acceso.

AhtseIV

Pantalla de las tablas existentes en la base de datos indicada en la pantalla inicial.

hY8IHIV

Una vez seleccionada una tabla y pulsar con el ratón encima de ella se extraen los datos de la tabla en 2 solapas.

Esta es la pantalla de la solapa con los campos de la tabla y su tipo (que será usado para formatear adecuadamente las celdas con los datos de los registros).

g0gmijW

Esta es la pantalla de la solapa de los datos de los registros en la tabla seleccionada.

C2WXsLc

Para bajarse el fichero con la macro y el código VBA seguir el siguiente enlace (hay que cambiar los datos para acceder al servidor remoto):
https://www.bc3toexcel.com/compartir/VBA_Application_to_access_data_in_a_remote_MySQL_Database_Table.xlsm
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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
En ThisWorkbook:
Option Explicit
 
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
          '---------------------------------------------------------------------------------------
          ' Procedure : Workbook_SheetFollowHyperlink
          ' Datetime  : 14/10/2020 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Return the the address of the cell when the user click on the link with the
          '             name of a table in the database
          '---------------------------------------------------------------------------------------
          '
          Dim rango As String
10        On Error GoTo Workbook_SheetFollowHyperlink_Error
20        rango = Target.Range.Address
          'MsgBox "'" & Sh.Name & "'!" & Target.Range.Address & " = " & Worksheets(Sh.Name).Range(rango).Value
30        Call ReadMySqlTable(Worksheets(Sh.Name).Range(rango).Value)
40        On Error GoTo 0
50        Exit Sub
Workbook_SheetFollowHyperlink_Error:
60        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in line " & Erl & " in procedure Workbook_SheetFollowHyperlink of ThisWorkbook"
End Sub
 
En Modulo1:
Option Explicit
'---------------------------------------------------------------------------------------
' Program   : Access to a any remote MySQL DataBase Tables
' Datetime  : 14/10/2020 13:56
' Author    : Aitor Solozabal Merino - [email protected].com
' Purpose   : Accesing to a remote MySql Server Database and show the data inside their tables
'---------------------------------------------------------------------------------------
'
'Global Variables
Dim oConn As ADODB.Connection
Function Connect_to_MySQL_Database() As Boolean
          '---------------------------------------------------------------------------------------
          ' Procedure : Connect_to_MySQL_Database
          ' Datetime  : 14/10/2020 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Set the connection with a remote MySql Server Database from data in cells
          '---------------------------------------------------------------------------------------
          '
          Dim DRIVER, SERVER, PORT As String
          Dim DATABASE As String
          Dim UID As String
          Dim PWD As String
          Dim Connect_String As String
10        On Error GoTo Connect_to_MySQL_Database_Error
20        Set oConn = New ADODB.Connection
30        Connect_to_MySQL_Database = False
40        DRIVER = Worksheets("MySQL_Connection_Parameters").Cells(2, 2).Value '"MySQL ODBC 8.0 Unicode Driver"
50        SERVER = Worksheets("MySQL_Connection_Parameters").Cells(3, 2).Value '"153.92.6.127 for Hostinger hosting Server"
60        PORT = Worksheets("MySQL_Connection_Parameters").Cells(4, 2).Value '"3306"
70        DATABASE = Worksheets("MySQL_Connection_Parameters").Cells(5, 2).Value 'u963209217 Database Name
80        UID = Worksheets("MySQL_Connection_Parameters").Cells(6, 2).Value 'u963209217admin User Name
90        PWD = Worksheets("MySQL_Connection_Parameters").Cells(7, 2).Value '[email protected] User Password
100       Connect_String = "Driver={" & DRIVER & "};SERVER=" & SERVER & ";DATABASE=" & DATABASE & ";PORT=" & PORT & ";UID=" & UID & ";PWD=" & PWD & ";"
110       If (Connect_String <> "") Then
120           oConn.Open Connect_String
130           If Not oConn Is Nothing Then
140               Connect_to_MySQL_Database = True
150           Else
160               MsgBox "Error: There is not a VALID connection with this remote MySql DATABASE"
170           End If
180       Else
190           MsgBox ("ERROR: Connection " & Connect_String & " FAILED")
200       End If
210       On Error GoTo 0
220       Exit Function
Connect_to_MySQL_Database_Error:
230       MsgBox "Error " & Err.Number & " (" & Err.Description & ") in line " & Erl & " in procedure Connect_to_MySQL_Database of Function Módulo1"
End Function
 
Public Sub ReadMySqlDataBase()
          '---------------------------------------------------------------------------------------
          ' Procedure : ReadMySqlDataBase
          ' Datetime  : 14/10/2020 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Return the list of tables that exist in database
          '---------------------------------------------------------------------------------------
          '
          Dim DATABASE As String
          Dim message As String
          Dim rs As ADODB.Recordset
          Dim sql_query As String
          Dim header As Field
          Dim intCol As Integer
          Dim rango As String
          Dim n As Integer
          Dim ultimafila As Integer
          Dim i As Integer
10        On Error GoTo ReadMySqlDataBase_Error
          '==========================================================================================
20        DATABASE = Worksheets("MySQL_Connection_Parameters").Cells(5, 2).Value
30        If Connect_to_MySQL_Database() Then
40            Speedon
50            sql_query = "SHOW TABLES FROM " + DATABASE + ";"
60            Set rs = New ADODB.Recordset
70            rs.Open sql_query, oConn, adOpenDynamic, adLockOptimistic
              'check for data
80            If (rs.EOF And rs.BOF) Then
90                message = "Error...No data returned." + vbCrLf
100               message = message + "Offending sql_query:" + vbCrLf
110               message = message + "---------------------------" + vbCrLf
120               message = message + sql_query + vbCrLf
130               message = message + "---------------------------" + vbCrLf
140               MsgBox message
150           Else
                  'clean sheet "Table_Data_Rows"
160               Worksheets("Table_Data_Rows").Cells.Clear
170               Worksheets("Table_Data_Rows").Cells.ClearContents
180               Application.CutCopyMode = False
                  'clean sheet "Table_Fields_Columns"
190               Worksheets("Table_Fields_Columns").Cells.Clear
200               Worksheets("Table_Fields_Columns").Cells.ClearContents
210               Application.CutCopyMode = False
                  'clean sheet "Database_Tables"
220               Worksheets("Database_Tables").Cells.Clear
230               Worksheets("Database_Tables").Cells.ClearContents
240               Application.CutCopyMode = False
250               Worksheets("Database_Tables").Activate
260               intCol = 0
270               For Each header In rs.Fields
280                   Range("A1").Cells(1, 1).Offset(0, intCol).Value = header.Name
290                   intCol = intCol + 1
300               Next header
310               ActiveSheet.Range("A2").CopyFromRecordset rs
320               rs.Close
330               Set rs = Nothing
                  'formating the headers of columns intcol from 0=A to intcol=???
340               rango = "A1:A1"
350               Range(rango).Select
360               Selection.Font.Bold = True
370               With Selection.Interior
380                   .Pattern = xlSolid
390                   .PatternColorIndex = xlAutomatic
400                   .ThemeColor = xlThemeColorLight1
410                   .TintAndShade = 0
420                   .PatternTintAndShade = 0
430               End With
440               With Selection.Font
450                   .ThemeColor = xlThemeColorDark1
460                   .TintAndShade = 0
470               End With
480               Cells.Select
490               Selection.AutoFilter
500               Selection.Columns.AutoFit
510               Selection.Rows.AutoFit
520               Range("A1").Select
530               ultimafila = Sheets("Database_Tables").UsedRange.Rows.Count
540               For i = 2 To ultimafila
550                   Range("A" & Trim(str(i))).Select
                      'add hiperlink to macro
560                   ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=Selection.Address, TextToDisplay:=Selection.Value
570               Next i
                  'set the first row as fixed
580               Rows("2:2").Select
590               With ActiveWindow
600                   .SplitColumn = 0
610                   .SplitRow = 1
620               End With
630               ActiveWindow.FreezePanes = True
640           End If
650           oConn.Close
660           Set oConn = Nothing
670           Speedoff
680           MsgBox ("Connection SUCCESFUL to " & DATABASE)
690       Else
700           MsgBox "Error en Connect_to_MySQL_Database - There is not a connection with the remote MySql SERVER"
710       End If
720       On Error GoTo 0
730       Exit Sub
ReadMySqlDataBase_Error:
740       MsgBox "Error " & Err.Number & " (" & Err.Description & ") in line " & Erl & " in procedure ReadMySqlDataBase"
End Sub
Public Sub ReadMySqlTable(TABLE As String)
          '---------------------------------------------------------------------------------------
          ' Procedure : ReadMySqlTable
          ' Datetime  : 14/10/2020 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Process to Return the DATA on a TABLE in a MySql DATABASE
          '             This Subroutine is CALLED FROM the event FollowHyperlink
          '             in the procedure Workbook_SheetFollowHyperlink in the sheet ThisWorkbook
          '             when the user click on the cell with the name of a Table in the Database
          '---------------------------------------------------------------------------------------
          '
          Dim DATABASE As String
          Dim message As String
          Dim rs As ADODB.Recordset
          Dim sql_query As String
          Dim Connect_String As String
          Dim header As Field
          Dim intCol As Integer
          Dim rango As String
          Dim n As Integer
          Dim lastcolumn As Long
10        On Error GoTo ReadMySqlTable_Error
20        DATABASE = Worksheets("MySQL_Connection_Parameters").Cells(5, 2).Value 'Split("u963209216_bc3,u963209216_aitor,u963209216_ka2", ",")
30        MsgBox "The clicked table is " & TABLE
40        If TABLE <> "" Then
50            If Connect_to_MySQL_Database() Then
60                Speedon
                  'clean sheet "Table_Data_Rows"
70                Worksheets("Table_Data_Rows").Cells.Clear
80                Worksheets("Table_Data_Rows").Cells.ClearContents
90                Application.CutCopyMode = False
                  'clean sheet "Table_Fields_Columns"
100               Worksheets("Table_Fields_Columns").Cells.Clear
110               Worksheets("Table_Fields_Columns").Cells.ClearContents
120               Application.CutCopyMode = False
130               If ReadMySqlTableFields(TABLE) Then
140                   Worksheets("Table_Fields_Columns").Range("A1:B1").Select
150                   Selection.Font.Bold = True
160                   With Selection.Interior
170                       .Pattern = xlSolid
180                       .PatternColorIndex = xlAutomatic
190                       .ThemeColor = xlThemeColorLight1
200                       .TintAndShade = 0
210                       .PatternTintAndShade = 0
220                   End With
230                   With Selection.Font
240                       .ThemeColor = xlThemeColorDark1
250                       .TintAndShade = 0
260                   End With
270                   Worksheets("Table_Fields_Columns").Range("A:B").Select
280                   Selection.AutoFilter
290                   Selection.Columns.AutoFit
300                   Selection.Rows.AutoFit
310                   Range("A1").Select
320                   Application.CutCopyMode = False
                      '============================================
330                   If ReadMySqlTableRows(TABLE) Then
340                       Speedoff
350                       lastcolumn = Sheets("Table_Data_Rows").UsedRange.Columns.Count
360                       Worksheets("Table_Data_Rows").Range("A:" & Number2Letter(lastcolumn)).Select
370                       Selection.AutoFilter
380                       Selection.Columns.AutoFit
390                       Selection.Rows.AutoFit
400                       Range("A1").Select
410                       Application.CutCopyMode = False
                          'mostrar el formulario para editar la hoja
420                       Worksheets("Table_Data_Rows").ShowDataForm
430                   Else
440                       MsgBox "Error: There are not DATA ROWS in this Table(" & TABLE & ")"
450                   End If
460               Else
470                   MsgBox "Error: There are not DATA FIELDS DEFINED in this in this Table(" & TABLE & ")"
480               End If
490               oConn.Close
500               Set oConn = Nothing
510               Speedoff
520           Else
530               MsgBox "Error en Connect_to_MySQL_Database - There is not a connection with the remote MySql SERVER"
540           End If
550       End If
560       On Error GoTo 0
570       Exit Sub
ReadMySqlTable_Error:
580       MsgBox "Error " & Err.Number & " (" & Err.Description & ") in line " & Erl & " in procedure ReadMySqlTable"
End Sub
Public Function ReadMySqlTableFields(TABLE As String) As Boolean
          '---------------------------------------------------------------------------------------
          ' Procedure : ReadMySqlTableFields
          ' Datetime  : 14/10/2020 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Return the list of FIELDS(COLUMNS) names and types of a TABLE in a MySql DATABASE
          '             and show in the sheet Columnas
          '---------------------------------------------------------------------------------------
          '
          Dim DATABASE As String
          Dim message As String
          Dim rs As ADODB.Recordset
          Dim sql_query As String
          Dim Connect_String As String
          Dim header As Field
          Dim intCol As Integer
          Dim rango As String
          Dim n As Integer
10        On Error GoTo ReadMySqlTableFields_Error
20        DATABASE = Worksheets("MySQL_Connection_Parameters").Cells(5, 2).Value
30        ReadMySqlTableFields = False
          '===========================================
40        Worksheets("Table_Fields_Columns").Activate
          '===========================================
50        Range("A1").Select
60        sql_query = "show columns from " + TABLE + ";"
70        MsgBox sql_query
80        Set rs = New ADODB.Recordset
90        rs.Open sql_query, oConn, adOpenDynamic, adLockOptimistic
          'check for data
100       If (rs.EOF And rs.BOF) Then
110           message = "Error...No data returned." + vbCrLf
120           message = message + "Offending sql_query:" + vbCrLf
130           message = message + "---------------------------" + vbCrLf
140           message = message + sql_query + vbCrLf
150           message = message + "---------------------------" + vbCrLf
160           MsgBox message
170       Else
180           ReadMySqlTableFields = True
190           intCol = 0
200           For Each header In rs.Fields
210               Range("A1").Cells(1, 1).Offset(0, intCol).Value = header.Name
220               intCol = intCol + 1
230           Next header
240           Range("A2").CopyFromRecordset rs
250           rs.Close
260           Set rs = Nothing
              'set the first row as fixed
270           Rows("2:2").Select
280           With ActiveWindow
290               .SplitColumn = 0
300               .SplitRow = 1
310           End With
320           ActiveWindow.FreezePanes = True
330       End If
340       On Error GoTo 0
350       Exit Function
ReadMySqlTableFields_Error:
360       MsgBox "Error " & Err.Number & " (" & Err.Description & ") in line " & Erl & " in procedure ReadMySqlTableFields"
End Function
Public Function ReadMySqlTableRows(TABLE As String) As Boolean
          '---------------------------------------------------------------------------------------
          ' Procedure : ReadMySqlTableRows
          ' Datetime  : 14/10/2020 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Return the DATA ROWS of a TABLE in a MySql DATABASE
          '---------------------------------------------------------------------------------------
          '
          Dim message As String
          Dim rs As ADODB.Recordset
          Dim sql_query As String
          Dim Connect_String As String
          Dim header As Field
          Dim intCol As Integer
          Dim rango As String
          Dim n As Integer
10        On Error GoTo ReadMySqlTableRows_Error
20        ReadMySqlTableRows = False
          '===========================================
30        Worksheets("Table_Data_Rows").Activate
          '===========================================
40        Range("A1").Select
50        sql_query = "SELECT * FROM " + TABLE + ";"
60        Set rs = New ADODB.Recordset
70        rs.Open sql_query, oConn, adOpenDynamic, adLockOptimistic
          'check for data
80        If (rs.EOF And rs.BOF) Then
90            message = "Error...No data returned." + vbCrLf
100           message = message + "Offending sql_query:" + vbCrLf
110           message = message + "---------------------------" + vbCrLf
120           message = message + sql_query + vbCrLf
130           message = message + "---------------------------" + vbCrLf
140           MsgBox message
150       Else
160           ReadMySqlTableRows = True
170           intCol = 0
180           For Each header In rs.Fields
190               Range("A1").Cells(1, 1).Offset(0, intCol).Value = header.Name
200               intCol = intCol + 1
210           Next header
              'copiar el resultado a la hoja
220           Range("A2").CopyFromRecordset rs
230           rs.Close
240           Set rs = Nothing
              '============================================
              'formatear la cabecera de las columnas
              'intcol from 0=A to intcol=???
250           rango = "A1:" & Number2Letter(intCol) & "1"
260           Range(rango).Select
270           Selection.Font.Bold = True
280           With Selection.Interior
290               .Pattern = xlSolid
300               .PatternColorIndex = xlAutomatic
310               .ThemeColor = xlThemeColorLight1
320               .TintAndShade = 0
330               .PatternTintAndShade = 0
340           End With
350           With Selection.Font
360               .ThemeColor = xlThemeColorDark1
370               .TintAndShade = 0
380           End With
              '=============================================================================================
              'tercero formatear las columnas en la hoja "Table_Data_Rows" conforme al DataType en la hoja "Table_Fields_Columns"
              '=============================================================================================
390           For n = 1 To intCol
400               rango = Number2Letter(n) & ":" & Number2Letter(n)
410               Select Case UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value)
                      Case "CHAR", "VARCHAR", "TINYTEXT", "TEXT", "MEDIUMTEXT", "LONGTEXT"
                          ' CHAR   A fixed-length nonbinary (character) string
                          ' VARCHAR    A variable-length non-binary string
                          ' TINYTEXT   A very small non-binary string
                          ' TEXT   A small non-binary string
                          ' MEDIUMTEXT A medium-sized non-binary string
                          ' LONGTEXT   A large non-binary string
420                       Columns(rango).Select
430                       Selection.NumberFormat = "@"
                          'Debug.Print "ALFANUMERICO = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & Rango
440                   Case "TINYINT", "SMALLINT", "MEDIUMINT", "INT", "BIGINT", "BIT"
                          ' TINYINT    A very small integer
                          ' SMALLINT   A small integer
                          ' MEDIUMINT  A medium-sized integer
                          ' INT    A standard integer
                          ' BIGINT A large integer
                          ' BIT    A bit field
450                       Columns(rango).Select
460                       Selection.NumberFormat = "0"
                          'Debug.Print "NUMERICO INTEGER = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & Rango
470                   Case "DECIMAL"
                          ' DECIMAL    A fixed-point number
480                       Columns(rango).Select
490                       Selection.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
                          'Debug.Print "NUMERICO FLOAT = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value)
500                   Case "FLOAT", "DOUBLE"
                          ' FLOAT  A single-precision floating point number
                          ' DOUBLE A double-precision floating point number
                          'ver punto decimal
510                       Columns(rango).Select
                          'Selection.NumberFormat = "0.00"
520                       Selection.NumberFormat = "General"
                          'Debug.Print "NUMERICO FLOAT = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value)
530                   Case "TINYINT(1)"
540                       Columns(rango).Select
                          'Selection.NumberFormat = "0.00"
550                       Selection.NumberFormat = "General"
                          'Debug.Print "BOOLEAN = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & Rango
560                   Case "DATE"
                          ' DATE   A date value in CCYY-MM-DD format
570                       Columns(rango).Select
580                       Selection.NumberFormat = "yyyy-mm-dd;@"
                          'Debug.Print "FECHA = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & Rango
590                   Case "DATETIME", "TIMESTAMP", "YEAR"
                          ' DATETIME   A date and time value in CCYY-MM-DD hh:mm:ssformat
                          ' TIMESTAMP  A timestamp value in CCYY-MM-DD hh:mm:ss format
600                       Columns(rango).Select
610                       Selection.NumberFormat = "yyyy/mm/dd h:mm"
                          'Debug.Print "FECHA = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & rango
620                   Case "YEAR"
                          ' YEAR   A year value in CCYY or YY format
630                       Columns(rango).Select
640                       Selection.NumberFormat = "yyyy"
                          'Debug.Print "FECHA = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & Rango
650                   Case "TIME"
                          ' TIME   A time value in hh:mm:ss format
660                       Columns(rango).Select
670                       Selection.NumberFormat = "h:mm:ss;@"
                          'Debug.Print "FECHA = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & Rango
680                   Case Else    ' Other values.
                          ' BINARY A fixed-length binary string
                          ' VARBINARY  A variable-length binary string
                          ' TINYBLOB   A very small BLOB (binary large object)
                          ' BLOB   A small BLOB
                          ' MEDIUMBLOB A medium-sized BLOB
                          ' LONGBLOB   A large BLOB
                          ' ENUM   An enumeration; each column value may be assigned one enumeration member
                          ' SET    A set; each column value may be assigned zero or more SET members
                          ' GEOMETRY    A spatial value of any type
                          ' POINT  A point (a pair of X-Y coordinates)
                          ' LINESTRING A curve (one or more POINT values)
                          ' POLYGON    A polygon
                          ' GEOMETRYCOLLECTION A collection of GEOMETRY values
                          ' MULTILINESTRING    A collection of LINESTRING values
                          ' MULTIPOINT A collection of POINT values
                          ' MULTIPOLYGON   A collection of POLYGON values
690                       Columns(rango).Select
700                       Selection.NumberFormat = "General"
                          'Debug.Print "TIPO = " & UCase(Worksheets("Table_Fields_Columns").Cells(n + 1, 2).Value) & " Rango=" & Rango
710               End Select
720           Next
730           Range("A1").Select
740       End If
750       On Error GoTo 0
760       Exit Function
ReadMySqlTableRows_Error:
770       MsgBox "Error " & Err.Number & " (" & Err.Description & ") in line " & Erl & " in procedure ReadMySqlTableRows"
End Function
Private Sub Speedoff()
          '---------------------------------------------------------------------------------------
          ' Procedure : Speedoff
          ' Datetime  : 14/06/2018 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Set the normal speed conditions
          '---------------------------------------------------------------------------------------
          '
10        On Error GoTo Speedoff_Error
20        With Application
30            .ScreenUpdating = True
40            .EnableEvents = True
50            .DisplayAlerts = True
60            .CalculateBeforeSave = True
70            .Cursor = xlDefault
80            .StatusBar = vbNullString
90            .EnableCancelKey = xlInterrupt
100           .CalculateFullRebuild
110           .Calculation = xlCalculationAutomatic
120       End With
130       Range("A1").Copy Range("A1") 'Clearundo
140       On Error GoTo 0
150       Exit Sub
Speedoff_Error:
160       MsgBox "Error " & Err.Number & " (" & Err.Description & ") In Procedure Speedoff, Line " & Erl & "."
End Sub
 
Private Sub Speedon()
          '---------------------------------------------------------------------------------------
          ' Procedure : Speedon
          ' Datetime  : 14/06/2018 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Set the optimal speed conditions
          '---------------------------------------------------------------------------------------
          '
10        On Error GoTo Speedon_Error
20        ActiveWorkbook.PrecisionAsDisplayed = True
30        ActiveWindow.DisplayZeros = False
40        With Application
50            .CutCopyMode = False
60            .ScreenUpdating = False
70            .EnableEvents = False
80            .DisplayAlerts = False
              '.Cursor = Xlwait
90            .StatusBar = vbNullString
100           .EnableCancelKey = xlErrorHandler
110           .DisplayStatusBar = True
120           .Calculation = xlCalculationManual   ' Poner Modo De Calculo Manual Para Mas Rapidez
130           .CalculateBeforeSave = False       ' Calcular Antes De Salvar Falso
140           .MaxChange = 0.001
150       End With
160       Range("A1").Copy Range("A1") 'Clearundo
170       On Error GoTo 0
180       Exit Sub
Speedon_Error:
190       MsgBox "Error " & Err.Number & " (" & Err.Description & ") In Procedure Speedon, Line " & Erl & "."
End Sub
Function Number2Letter(ByVal intcolumn As Long) As String
          '---------------------------------------------------------------------------------------
          ' Procedure : Number2Letter
          ' Datetime  : 14/06/2018 13:56
          ' Author    : Aitor Solozabal Merino - [email protected].com
          ' Purpose   : Return Column LETTER from a Column NUMBER
          '---------------------------------------------------------------------------------------
          '
10        On Error GoTo Number2Letter_Error
20        Number2Letter = Split(Cells(1, intcolumn).Address, "$")(1)
30        On Error GoTo 0
40        Exit Function
Number2Letter_Error:
50        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Number2Letter  Line " & Erl & "."
End Function



Comentarios sobre la versión: 1.0 (2)

Luis
26 de Noviembre del 2020
estrellaestrellaestrellaestrellaestrella
Bastante interesante el codigo, sin embargo El enlace no funciona
https://www.bc3toexcel.com/comparti...ss_data_in_a_remote_MySQL_Database_Table.xlsm
Responder
Imágen de perfil
28 de Noviembre del 2020
estrellaestrellaestrellaestrellaestrella
Perdona cosas que pasan y eres el primero en advertirlo, muchas gracias el enlace es:

https://www.bc3toexcel.com/compartir/VBA_Application_to_access_data_in_a_remote_MySQL_Database_Table.xlsm
Responder

Comentar la versión: 1.0

Nombre
Correo (no se visualiza en la web)
Valoración
Comentarios...
CerrarCerrar
CerrarCerrar
Cerrar

Tienes que ser un usuario registrado para poder insertar imágenes, archivos y/o videos.

Puedes registrarte o validarte desde aquí.

Codigo
Negrita
Subrayado
Tachado
Cursiva
Insertar enlace
Imagen externa
Emoticon
Tabular
Centrar
Titulo
Linea
Disminuir
Aumentar
Vista preliminar
sonreir
dientes
lengua
guiño
enfadado
confundido
llorar
avergonzado
sorprendido
triste
sol
estrella
jarra
camara
taza de cafe
email
beso
bombilla
amor
mal
bien
Es necesario revisar y aceptar las políticas de privacidad

http://lwp-l.com/s6732