ThisWorkbook.cls
-----------------------------------------
VERSION 1.0 CLASS
BEGINMultiUse = -1 'True
END
Attribute VB_Name = "ThisWorkbook"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Const gs_toolbar_1 As String = "my_toolbar_db_1"
Private Const gs_toolbar_2 As String = "my_toolbar_db_2"
Private Const gs_toolbar_3 As String = "my_toolbar_db_3"
Private Const gs_toolbar_4 As String = "my_toolbar_db_4"
Private Sub Workbook_Activate()
Dim lcb_commdbar As CommandBar
On Error GoTo error_exit
Set lcb_commdbar = Application.CommandBars(gs_toolbar_1)
lcb_commdbar.Visible = True
Set lcb_commdbar = Application.CommandBars(gs_toolbar_2)
lcb_commdbar.Visible = True
Set lcb_commdbar = Application.CommandBars(gs_toolbar_3)
lcb_commdbar.Visible = True
Set lcb_commdbar = Application.CommandBars(gs_toolbar_4)
lcb_commdbar.Visible = True
error_exit:
Set lcb_commdbar = Nothing
End Sub
Private Sub Workbook_Deactivate()
Dim lcb_commdbar As CommandBar
On Error GoTo error_exit
Set lcb_commdbar = Application.CommandBars(gs_toolbar_1)
lcb_commdbar.Visible = False
Set lcb_commdbar = Application.CommandBars(gs_toolbar_2)
lcb_commdbar.Visible = False
Set lcb_commdbar = Application.CommandBars(gs_toolbar_3)
lcb_commdbar.Visible = False
Set lcb_commdbar = Application.CommandBars(gs_toolbar_4)
lcb_commdbar.Visible = False
error_exit:
Set lcb_commdbar = Nothing
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Call sub_RemoveToolBar(gs_toolbar_1)
Call sub_RemoveToolBar(gs_toolbar_2)
Call sub_RemoveToolBar(gs_toolbar_3)
Call sub_RemoveToolBar(gs_toolbar_4)
' Call sub_remove_all_bars
Call f_disconnect_db
End Sub
Private Sub Workbook_Open()
Application.OnKey "+^d", "sub_AutoFill"
gs_saved_path = ThisWorkbook.Path
gs_freeze_screen = "TOP"
'gl_MaxRow_ofExcel = ThisWorkbook.Sheets(1).Columns(1).Rows.Count
'gl_MaxCol_ofExcel = ThisWorkbook.Sheets(1).Rows(1).Columns.Count
Dim ls_toolbar As String
Call sub_remove_all_bars
'============================================================================================
ls_toolbar = gs_toolbar_1
Call sub_RemoveToolBar(ls_toolbar)
Call sub_add_new_bar(ls_toolbar)
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Create Table Sheet", _
as_on_action:="sub_create_table_sheet", ai_face_id:=300, _
as_tip_text:="Create a new sheet for table you selected")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Reset Link/Condi Format", _
as_on_action:="sub_RefreshLink_n_ResetCondFormat", ai_face_id:=53, _
as_tip_text:="Reset Link/Condi Format")
' Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Refresh link for all", _
' as_on_action:="sub_RefreshLink_For_AllSheet", ai_face_id:=53, _
' as_tip_text:="Refresh link for all sheets")
'
' Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Refresh Conditional Format", _
' as_on_action:="sub_refresh_cond_format", ai_face_id:=639, _
' as_tip_text:="Refresh Conditional Format")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Merge all cells", _
as_on_action:="sub_merge_all_cells", ai_face_id:=402, _
as_tip_text:="Merge all cells for the table definition file")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="CreateTableSheet-ForAll", _
as_on_action:="sub_create_table_sheet_for_all", ai_face_id:=302, _
as_tip_text:="Create all tables' sheet")
' Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="", _
' as_on_action:="'sub_RemoveToolBar """ & gs_toolbar_1 & """'", ai_face_id:=722, _
' as_tip_text:="Exit this toolbar")
'============================================================================================
'============================================================================================
ls_toolbar = gs_toolbar_2
Call sub_RemoveToolBar(ls_toolbar)
Call sub_add_new_bar(ls_toolbar)
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Gen Insert SQL", _
as_on_action:="sub_gen_insert_sql", ai_face_id:=301, _
as_tip_text:="Generate Insert SQL script")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Protect Cell", _
as_on_action:="sub_lock_cells", ai_face_id:=308, _
as_tip_text:="Lock cells to enable edit")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="UnProtect Cell", _
as_on_action:="sub_unlock_cells", ai_face_id:=309, _
as_tip_text:="Lock cells to enable edit")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Clear filter", _
as_on_action:="sub_clear_filter", ai_face_id:=605, _
as_tip_text:="Clear filter")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Clear filter for all", _
as_on_action:="sub_clear_filter_criteria", ai_face_id:=605, _
as_tip_text:="Clear filter for all")
' Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="", _
' as_on_action:="'sub_RemoveToolBar """ & gs_toolbar_2 & """'", ai_face_id:=722, _
' as_tip_text:="Exit this toolbar")
'============================================================================================
'============================================================================================
ls_toolbar = gs_toolbar_3
Call sub_RemoveToolBar(ls_toolbar)
Call sub_add_new_bar(ls_toolbar)
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Format data", _
as_on_action:="sub_format_data", ai_face_id:=501, _
as_tip_text:="Format data")
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="Move to LeftMost", _
as_on_action:="sub_move_to_leftmost", ai_face_id:=320, _
as_tip_text:="Move to leftmost")
' Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="", _
' as_on_action:="'sub_RemoveToolBar """ & gs_toolbar_2 & """'", ai_face_id:=722, _
' as_tip_text:="Exit this toolbar")
'============================================================================================
'============================================================================================
ls_toolbar = gs_toolbar_4
Call sub_RemoveToolBar(ls_toolbar)
Call sub_add_new_bar(ls_toolbar)
Call sub_add_new_button(as_bar_name:=ls_toolbar, as_btn_caption:="RetrieveDataFromDB", _
as_on_action:="sub_retrieve_data", ai_face_id:=101, _
as_tip_text:="Retrieve DB")
End Sub
Module_Toolbar1.bas
--------------------------------------
Attribute VB_Name = "Module_Toolbar1"
Option Explicit
Public Const gs_summary_sheet = "Summary"
Public Const COL_TABLE_NAME = 2
Public Const COL_COLUMN_NAME = 4
Public Const COL_LINK_IN_SUMRY = 7
Public go_summary_sheet As Worksheet
Public gl_xls_max_row As Long
Option Base 1
Public Sub sub_create_table_sheet()
Dim ls_new_sheet As String
Dim ls_link_origin_cont As String
Dim sheet_no As Integer
Dim sheet_count As Integer
'Dim ls_active_sheet As String
Dim li_tab_1st_row As Long
Dim li_tab_last_row As Long
Dim li_sheet_max_row As Long
Dim li_new_sheet_col_no As Integer
Dim li_active_row As Integer
Dim li_row_no_tmp As Integer
Dim link_add As String
Dim ls_summary_sheet As String
Dim Response As String
If ActiveCell.Row <= 1 Then
MsgBox "you selected the wrong line!"
Exit Sub
End If
li_tab_1st_row = 0
On Error GoTo error_exit
'ls_active_sheet = ActiveSheet.Name
If f_initial_for_tab_link("1,2") < 0 Then
Exit Sub
End If
go_summary_sheet.Activate
gl_xls_max_row_no = Columns(1).Rows.Count
With go_summary_sheet
li_active_row = 0
li_active_row = ActiveCell.Cells.Row
ls_new_sheet = .Cells(li_active_row, COL_TABLE_NAME).Value
For li_row_no_tmp = li_active_row To 2 Step -1
If .Cells(li_row_no_tmp, COL_TABLE_NAME).Value <> .Cells(li_row_no_tmp - 1, COL_TABLE_NAME).Value Then
li_tab_1st_row = li_row_no_tmp
Exit For
End If
Next
sheet_count = Sheets.Count
For sheet_no = 1 To sheet_count
If Sheets(sheet_no).Name = ls_new_sheet Then
MsgBox "Sheet " & ls_new_sheet & " already exist"
Exit Sub
End If
Next
Sheets.Add.Name = ls_new_sheet
ActiveWorkbook.Sheets(ls_new_sheet).Move After:=go_summary_sheet
ls_link_origin_cont = Trim(go_summary_sheet.Cells(li_tab_1st_row, COL_LINK_IN_SUMRY).Value)
If ls_link_origin_cont = "" Or IsNull(ls_link_origin_cont) Then
ls_link_origin_cont = ls_new_sheet
End If
With go_summary_sheet.Cells(li_tab_1st_row, COL_LINK_IN_SUMRY)
go_summary_sheet.Hyperlinks.Add Anchor:=go_summary_sheet.Cells(li_tab_1st_row, COL_LINK_IN_SUMRY), Address:="", _
SubAddress:="'" & ls_new_sheet & "'" & "!A1", TextToDisplay:=ls_link_origin_cont
End With
li_new_sheet_col_no = 1
'li_sheet_max_row = Sheets(ls_active_sheet).Range("B104857").End(xlUp).Row
'li_sheet_max_row = Sheets(ls_active_sheet).Range("B104857").End(xlUp).Row
li_sheet_max_row = go_summary_sheet.Cells(gl_xls_max_row_no, COL_TABLE_NAME).End(xlUp).Row
For li_row_no_tmp = li_tab_1st_row To li_sheet_max_row
With Sheets(ls_new_sheet)
.Cells(1, li_new_sheet_col_no).Value = go_summary_sheet.Cells(li_row_no_tmp, 4).Value
End With
li_new_sheet_col_no = li_new_sheet_col_no + 1
If .Cells(li_row_no_tmp, COL_TABLE_NAME).Value <> .Cells(li_row_no_tmp + 1, COL_TABLE_NAME).Value Then
li_tab_last_row = li_row_no_tmp
Sheets(ls_new_sheet).Hyperlinks.Add Anchor:=Cells(1, 1), Address:="", _
SubAddress:="'" & gs_summary_sheet & "'" & "!G" & li_tab_1st_row
With ActiveWindow
.SplitColumn = 1
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
ActiveWindow.DisplayGridlines = False
Range(Cells(1, 1), Cells(1, li_tab_last_row - li_tab_1st_row + 1)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
'Selection.NumberFormat = "@"
Cells(1, 1).Select
Exit For
End If
Next
End With
Sheets(gs_summary_sheet).Activate
error_exit: Exit Sub
End Sub
Public Sub sub_RefreshLink_n_ResetCondFormat()
' Dim ls_response As String
'
' ls_response = MsgBox("This will clear all the conditional format, and reset it," & Chr(13) & _
' "Please check if you are openning the correct workbook & sheet ""Summary"" " & Chr(13) & _
' "Are you sure ?", _
' vbCritical + vbYesNoCancel + vbDefaultButton2, "Be careful")
' If ls_response <> vbYes Then
' Exit Sub
' End If
Call sub_RefreshLink_For_AllSheet
Call sub_refresh_cond_format
End Sub
Sub sub_RefreshLink_For_AllSheet()
Dim lrng_found As Range
Dim ls_link_origin_cont As String
Dim each_sheet As Worksheet
Dim Response As String
On Error GoTo 0
If f_initial_for_tab_link("1,2") < 0 Then
Exit Sub
End If
If ActiveWorkbook.Sheets.Count = 0 Then
Exit Sub
End If
If Worksheets.Count = 0 Then
Exit Sub
End If
go_summary_sheet.Activate
'For Each each_sheet In ActiveWorkbook.Sheets
For Each each_sheet In ActiveWorkbook.Worksheets
'MsgBox (each_sheet.Name)
If each_sheet.Name <> gs_summary_sheet Then
Set lrng_found = Sheets(gs_summary_sheet).Range("B:B").Find(what:=each_sheet.Name, LookIn:=xlValues, LookAt:=xlWhole)
If Not lrng_found Is Nothing Then
ls_link_origin_cont = Trim(each_sheet.Cells(1, 1).Value)
each_sheet.Hyperlinks.Add Anchor:=each_sheet.Cells(1, 1), Address:="", _
SubAddress:="'" & gs_summary_sheet & "'!" & lrng_found.Address, TextToDisplay:=ls_link_origin_cont
End If
End If
Next
End Sub
Sub sub_refresh_cond_format()
On Error GoTo 0
Dim ls_temp As String
Dim lrng_range As Range
ls_temp = Sheets("Summary").Name
If Trim(ls_temp) = "" Then
MsgBox ("No sheet ""Summary"", please check!")
Exit Sub
End If
Sheets("Summary").Activate
gl_xls_max_row_no = Range("A:A").Rows.Count
Cells.FormatConditions.Delete
'set grid for all
Set lrng_range = Sheets("Summary").Range("$A$1:$J$" & gl_xls_max_row_no)
lrng_range.FormatConditions.Add Type:=xlExpression, Formula1:="=LEN($B1)>0"
lrng_range.FormatConditions(lrng_range.FormatConditions.Count).SetFirstPriority
With lrng_range.FormatConditions(1).Borders(xlLeft)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With lrng_range.FormatConditions(1).Borders(xlRight)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With lrng_range.FormatConditions(1).Borders(xlTop)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With lrng_range.FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
lrng_range.FormatConditions(1).StopIfTrue = False
' set separator in different tables
Set lrng_range = Range("$A$2:$E$" & gl_xls_max_row_no)
lrng_range.FormatConditions.Add Type:=xlExpression, Formula1:="=AND($B1<>$B2)"
lrng_range.FormatConditions(lrng_range.FormatConditions.Count).SetFirstPriority
With lrng_range.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599963377788629
End With
lrng_range.FormatConditions(1).StopIfTrue = False
' set not-null columns
Set lrng_range = Range("$H$2:$H$" & gl_xls_max_row_no)
lrng_range.FormatConditions.Add Type:=xlExpression, Formula1:="=AND($H2=""N"")"
lrng_range.FormatConditions(lrng_range.FormatConditions.Count).SetFirstPriority
With lrng_range.FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
lrng_range.FormatConditions(1).StopIfTrue = False
'set key column
Set lrng_range = Range("I:I")
lrng_range.FormatConditions.Add Type:=xlExpression, Formula1:="=AND($I1=""Y"")"
lrng_range.FormatConditions(lrng_range.FormatConditions.Count).SetFirstPriority
With lrng_range.FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
lrng_range.FormatConditions(1).StopIfTrue = False
Cells(1, "A").Select
End Sub
Public Sub sub_merge_all_cells()
Dim ls_merge_col_id As String
Dim ls_based_col_id As String
ls_merge_col_id = "G" ' merge column
ls_based_col_id = "B" 'based on this column, if same, then merge G
If ActiveSheet.Name <> "Summary" Then
MsgBox ("This applies to sheet <Summary> only !")
Exit Sub
End If
Dim Response
Response = MsgBox("Are you sure? " & _
Chr(13) & _
"Please backup your file first, it's critical!", _
vbYesNo + vbCritical + vbDefaultButton2, "Be careful")
If Response = vbYes Then
Else ' User chose No.
Exit Sub
End If
'On Error GoTo error_exit
Dim ll_max_row As Long
Dim ll_start_row As Long
Dim ll_end_row As Long
Dim lo_rng As Range
'Set lo_rng = Selection
If f_initial_for_tab_link("1,2") < 0 Then
Exit Sub
End If
go_summary_sheet.Activate
ll_start_row = 2
ll_end_row = f_get_valid_data_max_row(go_summary_sheet)
' Application.DisplayAlerts = False
Dim row_no As Long
'Application.ScreenUpdating = False
go_summary_sheet.Range(ls_merge_col_id & ll_start_row & ":" & ls_merge_col_id & ll_end_row).UnMerge
'With ActiveSheet
'For row_no = ll_end_row To ll_start_row Step -1
For row_no = ll_end_row To 2 Step -1
If Range(ls_based_col_id & row_no) = Range(ls_based_col_id & (row_no - 1)) Then
Range(ls_merge_col_id & row_no & ":" & ls_merge_col_id & (row_no - 1)).Merge
End If
' If .Cells(row_no, 2).Value = .Cells(row_no - 1, 2).Value Then
' .Range(.Cells(row_no, 7), .Cells(row_no - 1, 7)).Merge
' End If
Next
'End With
go_summary_sheet.Range(ls_merge_col_id & ll_start_row & ":" & ls_merge_col_id & ll_end_row).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
'Application.DisplayAlerts = True
Application.ScreenUpdating = True
error_exit:
Exit Sub
End Sub
Public Sub sub_create_table_sheet_for_all()
Dim ls_new_sheet As String
Dim ls_link_origin_cont As String
Dim sheet_no As Integer
Dim sheet_count As Integer
Dim li_sheet_max_row As Long
Dim li_new_sheet_col_no As Integer
Dim li_active_row As Integer
Dim li_row_no_tmp As Integer
Dim link_add As String
Dim Response
Response = MsgBox("It may take much time, to continue? ", _
vbYesNo + vbCritical + vbDefaultButton2, "")
If Response = vbYes Then
Else ' User chose No.
Exit Sub
End If
If f_initial_for_tab_link("1,2") < 0 Then
Exit Sub
End If
go_summary_sheet.Activate
Dim ll_max_row As Long
ll_max_row = f_get_valid_data_max_row(go_summary_sheet)
If ll_max_row <= 2 Then
MsgBox "There is no actual data in sheet " & gs_summary_sheet & "!"
Exit Sub
End If
Dim ls_table_name As String
Dim ll_tab_start_row As Long
Dim ll_tab_end_row As Long
Dim ll_each_row As Long
For ll_each_row = 2 To ll_max_row
ls_table_name = Trim(go_summary_sheet.Cells(ll_each_row, COL_TABLE_NAME))
If Len(ls_table_name) = 0 Then
GoTo cont_next_line
End If
If ll_each_row = 2 Then
Else
If ls_table_name = Trim(go_summary_sheet.Cells(ll_each_row - 1, COL_TABLE_NAME)) Then
GoTo cont_next_line
End If
End If
If f_if_sheet_exists(go_summary_sheet.Cells(ll_each_row, COL_TABLE_NAME)) Then
GoTo cont_next_line
End If
ll_tab_start_row = f_get_tab_1st_row(ll_each_row) 'actually, it equals to ll_each_row
ll_tab_end_row = f_get_tab_last_row(ll_each_row)
If f_create_link_for_table(ll_tab_start_row, ll_tab_end_row) < 0 Then
MsgBox "Error, please check!"
End If
cont_next_line:
Next
Call Sort_Sheets
Sheets(gs_summary_sheet).Move Before:=Sheets(1)
go_summary_sheet.Activate
End Sub
Function f_create_link_for_table(ByVal al_tab_start_row As Long _
, ByVal al_tab_end_row As Long)
f_create_link_for_table = 1
ThisWorkbook.Activate
Dim ls_new_sheet As String
ls_new_sheet = go_summary_sheet.Cells(al_tab_start_row, COL_TABLE_NAME)
Sheets.Add.Name = ls_new_sheet
Dim ls_link_origin_cont As String
ls_link_origin_cont = Trim(go_summary_sheet.Cells(al_tab_start_row, COL_LINK_IN_SUMRY).Value)
If ls_link_origin_cont = "" Or IsNull(ls_link_origin_cont) Then
ls_link_origin_cont = ls_new_sheet
End If
With go_summary_sheet.Cells(al_tab_start_row, COL_LINK_IN_SUMRY)
go_summary_sheet.Hyperlinks.Add Anchor:=go_summary_sheet.Cells(al_tab_start_row, COL_LINK_IN_SUMRY), Address:="", _
SubAddress:="'" & ls_new_sheet & "'" & "!A1", TextToDisplay:=ls_link_origin_cont
End With
ThisWorkbook.Sheets(ls_new_sheet).Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
If f_copy_columns_to_new_sheet(al_tab_start_row, al_tab_end_row) < 0 Then
MsgBox "Error during calling f_copy_columns_to_new_sheet"
End If
End Function
Function f_copy_columns_to_new_sheet(ByVal al_tab_start_row As Long _
, ByVal al_tab_end_row As Long)
Dim lo_dest_sheet As Worksheet
Set lo_dest_sheet = ThisWorkbook.Worksheets(Trim(go_summary_sheet.Cells(al_tab_start_row, COL_TABLE_NAME)))
Dim ll_each_row As Long
Dim ll_col_num As Long
ll_col_num = 0
For ll_each_row = al_tab_start_row To al_tab_end_row
ll_col_num = ll_col_num + 1
lo_dest_sheet.Cells(1, ll_col_num) = go_summary_sheet.Cells(ll_each_row, COL_COLUMN_NAME)
Next
'create link back
lo_dest_sheet.Hyperlinks.Add Anchor:=lo_dest_sheet.Cells(1, 1), Address:="", _
SubAddress:="'" & gs_summary_sheet & "'" & "!G" & al_tab_start_row
'set format as below
lo_dest_sheet.Activate
ActiveWindow.SplitColumn = 1
ActiveWindow.SplitRow = 1
ActiveWindow.FreezePanes = True
ActiveWindow.DisplayGridlines = False
lo_dest_sheet.Range(lo_dest_sheet.Cells(1, 1), lo_dest_sheet.Cells(1, ll_col_num)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
'Selection.NumberFormat = "@"
Cells(1, 1).Select
End Function
Function f_get_tab_1st_row(ByVal al_curr_row As Long)
Dim ll_each_row As Long
For ll_each_row = al_curr_row To 2 Step -1
If ll_each_row = 2 Then
f_get_tab_1st_row = ll_each_row
Exit Function
Else
If Trim(go_summary_sheet.Cells(ll_each_row, COL_TABLE_NAME)) <> _
Trim(go_summary_sheet.Cells(ll_each_row - 1, COL_TABLE_NAME)) Then
f_get_tab_1st_row = ll_each_row
Exit Function
End If
End If
Next
End Function
Function f_get_tab_last_row(ByVal al_curr_row As Long)
Dim ll_each_row As Long
For ll_each_row = al_curr_row To gl_xls_max_row
If ll_each_row = gl_xls_max_row Then
f_get_tab_last_row = ll_each_row
Exit Function
Else
If Trim(go_summary_sheet.Cells(ll_each_row, COL_TABLE_NAME)) <> _
Trim(go_summary_sheet.Cells(ll_each_row + 1, COL_TABLE_NAME)) Then
f_get_tab_last_row = ll_each_row
Exit Function
End If
End If
Next
End Function
Function f_initial_for_tab_link(ByVal as_type As String) As Integer
f_initial_for_tab_link = 1
Dim ls_param_string As String
ls_param_string = "," & Replace(as_type, " ", "", 1, -1, vbTextCompare) & "," ',1,2,3,4,5,6,
Dim Response As String
If InStr(ls_param_string, ",1,") > 0 Then
On Error Resume Next
'Set sheet_summary = Sheets.Item (gs_summary_sheet)
Set go_summary_sheet = ThisWorkbook.Worksheets(gs_summary_sheet)
On Error GoTo 0
If go_summary_sheet Is Nothing Then
f_initial_for_tab_link = -1
Response = MsgBox("There's no sheet named " + gs_summary_sheet + "," _
+ Chr(10) + Chr(13) _
+ "please make sure if this function works for current workbook or not !", _
vbOKOnly + vbExclamation, "Caution")
Exit Function
End If
End If
If InStr(ls_param_string, ",2,") > 0 Then
gl_xls_max_row = ThisWorkbook.Sheets(1).Columns(1).Rows.Count
End If
End Function
Module_Toolbar3.bas
--------------------------------------------
Attribute VB_Name = "Module_Toolbar3"
Option Explicit
Option Base 1
Public Sub sub_format_data()
Dim lo_range As Range
Dim ll_max_row As Long
Dim ll_max_col As Long
ll_max_row = f_get_valid_data_max_row(ActiveSheet)
'll_max_col = f_get_valid_data_max_col(ActiveSheet)
ll_max_col = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
Set lo_range = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ll_max_row, ll_max_col))
lo_range.Borders(xlEdgeLeft).LineStyle = xlContinuous
lo_range.Borders(xlEdgeTop).LineStyle = xlContinuous
lo_range.Borders(xlEdgeBottom).LineStyle = xlContinuous
lo_range.Borders(xlEdgeRight).LineStyle = xlContinuous
lo_range.Borders(xlInsideVertical).LineStyle = xlContinuous
lo_range.Borders(xlInsideHorizontal).LineStyle = xlContinuous
'ActiveSheet.Columns(1, ll_max_col).EntireColumn.AutoFit
ActiveSheet.Range(ActiveSheet.Columns(1), ActiveSheet.Columns(ll_max_col)).EntireColumn.AutoFit
Dim ll_each_row As Long
For ll_each_row = 2 To ll_max_row
If WorksheetFunction.CountA(Rows(ll_each_row)) <= 0 Then
Set lo_range = ActiveSheet.Range(ActiveSheet.Cells(ll_each_row, 1), ActiveSheet.Cells(ll_each_row, ll_max_col))
' lo_range.Borders(xlEdgeLeft).LineStyle = none
' lo_range.Borders(xlEdgeTop).LineStyle = xlContinuous
' lo_range.Borders(xlEdgeBottom).LineStyle = xlContinuous
' lo_range.Borders(xlEdgeRight).LineStyle = xlContinuous
' lo_range.Borders(xlInsideVertical).LineStyle = xlContinuous
' lo_range.Borders(xlInsideHorizontal).LineStyle = xlContinuous
lo_range.Borders(xlDiagonalDown).LineStyle = xlNone
lo_range.Borders(xlDiagonalUp).LineStyle = xlNone
lo_range.Borders(xlEdgeLeft).LineStyle = xlNone
lo_range.Borders(xlEdgeRight).LineStyle = xlNone
lo_range.Borders(xlInsideVertical).LineStyle = xlNone
lo_range.Borders(xlInsideHorizontal).LineStyle = xlNone
'lo_range.Borders(xlEdgeTop).LineStyle = xlNone
'lo_range.Borders(xlEdgeBottom).LineStyle = xlNone
End If
Next
'wrap text
With ActiveSheet.Rows(1)
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Public Sub sub_move_to_leftmost()
Dim larr_sheet() As String
Dim li_cnt As Integer
li_cnt = 0
Dim WS As Worksheet
For Each WS In ActiveWindow.SelectedSheets
li_cnt = li_cnt + 1
ReDim Preserve larr_sheet(1 To li_cnt)
larr_sheet(li_cnt) = WS.Name
Next WS
Sheets(larr_sheet).Move After:=ActiveWorkbook.Sheets("Summary")
'ActiveSheet.Move after:=ActiveWorkbook.Sheets("Summary")
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
End Sub
Module_SUB_Functions.bas
--------------------------------------------------
Attribute VB_Name = "Module_SUB_Functions"
Option Explicit
Option Base 1
Public gs_saved_path As String
'If Val(Application.Version) >= 12 Then
Public Const gl_MaxRow_ofExcel = 1048576
Public Const gl_MaxCol_ofExcel = 16384
'Else
' Public Const gl_MaxRow_ofExcel = 123
' Public Const gl_MaxCol_ofExcel = 234
'End If
Public gs_env As String
Public gs_current_path As String
Public gs_freeze_screen As String
Public gl_xls_max_row_no As Long
Public gl_xls_max_col_no As Long
Sub sub_clear_filter_criteria()
Dim each_sheet As Worksheet
Dim ls_tmp_name As String
On Error Resume Next
' If Not ActiveWorkbook Then
' Exit Sub
' End If
For Each each_sheet In ActiveWorkbook.Worksheets
'If each_sheet.FilterMode Then
each_sheet.ShowAllData
'End If
Next
End Sub
Sub sub_clear_filter()
' Dim myrange
' myrange = Split(ActiveCell.Address, "$")(1)
' MsgBox ActiveCell.Address & "---" & myrange
Dim ll_col_no As Long
ll_col_no = ActiveCell.Column
Application.ScreenUpdating = False
ActiveSheet.UsedRange.AutoFilter Field:=ll_col_no
'MsgBox ActiveCell.Address
Application.GoTo Reference:=ActiveCell, scroll:=False
'ActiveWindow.SmallScroll Down:=78
'MsgBox ActiveCell.Left & vbCrLf & ActiveCell.Top
Application.ScreenUpdating = True
End Sub
'Public Function f_find_col_type(ByRef arr_range, ByVal as_sheet_name As String, ByVal as_col_name As String) As String
Public Function f_find_col_type(ByRef dct_table_row As Dictionary, ByRef arr_range, ByVal as_sheet_name As String, ByVal as_col_name As String) As String
Dim ls_summary_sheet As String
ls_summary_sheet = "Summary"
Dim ll_start_row As Long
Dim ll_end_row As Long
Dim ll_next_row As Long
Dim larr_table
'll_start_row = Application.Match(as_sheet_name, arr_range, 0)
'll_start_row = WorksheetFunction.Match(as_sheet_name, arr_range, 0)
ll_start_row = dct_table_row(as_sheet_name)
If ll_start_row > 0 Then
ll_next_row = ll_start_row + 1
Do
If arr_range(ll_start_row, 1) = arr_range(ll_next_row, 1) Then
ll_next_row = ll_next_row + 1
Else
ll_end_row = ll_next_row - 1
Exit Do
End If
Loop
Dim larr_cols
larr_cols = Sheets(ls_summary_sheet).Range("D" & ll_start_row & ":D" & ll_end_row)
Dim ll_col_row As Long
ll_col_row = Application.Match(as_col_name, larr_cols, 0)
If ll_col_row > 0 Then
ll_col_row = ll_start_row + ll_col_row - 1
Dim ls_type As String
ls_type = Sheets(ls_summary_sheet).Range("E" & ll_col_row)
If InStr(1, UCase(ls_type), "NUMBER", vbTextCompare) > 0 Then
f_find_col_type = "NUMBER"
ElseIf InStr(1, UCase(ls_type), "DATE", vbTextCompare) > 0 Then
f_find_col_type = "DATE"
ElseIf InStr(1, UCase(ls_type), "CHAR", vbTextCompare) > 0 Then
f_find_col_type = "STRING"
Else
f_find_col_type = UCase(ls_type)
End If
Exit Function
Else
MsgBox "Column " & as_col_name & " not found!"
f_find_col_type = "ERROR"
Exit Function
End If
Else
f_find_col_type = "ERROR"
Exit Function
End If
End Function
Public Function f_find_del_keys(ByRef dct_table_row As Dictionary _
, ByVal arr_range, ByVal as_sheet_name As String _
, ByRef ldct_del_keys As Dictionary) ' As Dictionary
Dim ls_summary_sheet As String
'Dim ldct_del_keys As New Dictionary
ls_summary_sheet = "Summary"
Dim ll_start_row As Long
Dim ll_end_row As Long
Dim ll_next_row As Long
Dim larr_table
'll_start_row = Application.Match(as_sheet_name, arr_range, 0)
'll_start_row = WorksheetFunction.Match(as_sheet_name, arr_range, 0)
ll_start_row = dct_table_row(as_sheet_name)
If ll_start_row > 0 Then
ll_next_row = ll_start_row + 1
Do
If arr_range(ll_start_row, 1) = arr_range(ll_next_row, 1) Then
ll_next_row = ll_next_row + 1
Else
ll_end_row = ll_next_row - 1
Exit Do
End If
Loop
Dim larr_keys
larr_keys = Sheets(ls_summary_sheet).Range("D" & ll_start_row & ":J" & ll_end_row)
Dim ll_each_key_row As Long
For ll_each_key_row = 1 To UBound(larr_keys, 1)
If Len(Trim(larr_keys(ll_each_key_row, 7))) > 0 Then
If Not ldct_del_keys.Exists(larr_keys(ll_each_key_row, 1)) Then
ldct_del_keys.Add larr_keys(ll_each_key_row, 1), ll_each_key_row
End If
End If
Next
End If
'f_find_del_keys = ldct_del_keys
End Function
Sub sub_AutoFill()
Dim li_curr_col As Integer
li_curr_col = ActiveCell.Column
Dim ll_curr_row As Long
ll_curr_row = ActiveCell.Row
If Trim(ActiveCell.Text) <> "" Then Exit Sub
If Trim(ActiveSheet.Cells(ll_curr_row + 1, li_curr_col).Text) <> "" Then
ActiveCell.FillDown
Exit Sub
End If
Dim ll_max_row_no As Long
ll_max_row_no = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
Dim larr_rng
larr_rng = ActiveSheet.Range(ActiveSheet.Cells(1, li_curr_col), ActiveSheet.Cells(ll_max_row_no, li_curr_col))
Dim ll_max_blank_row As Long
Dim ll_row As Long
ll_max_blank_row = ll_curr_row + 1
For ll_row = ll_curr_row + 1 To ll_max_row_no
If larr_rng(ll_row, 1) = "" Then
ll_max_blank_row = ll_row
Else
Exit For
End If
Next
If ll_max_blank_row = ll_curr_row Then Exit Sub
ActiveCell.FillDown
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.AutoFill Destination:=ActiveSheet.Range(ActiveSheet.Cells(ll_curr_row, li_curr_col), ActiveSheet.Cells(ll_max_blank_row, li_curr_col))
End Sub
Public Function f_get_file_save_path(ByRef as_output_file As String)
Dim fso As New FileSystemObject
Dim ls_output_file As String
'Dim ls_drive As String
Dim ls_curr_path As String
ls_curr_path = gs_saved_path
If ls_curr_path = "" Then ls_curr_path = Trim(ThisWorkbook.Path)
'ls_drive = fso.GetDriveName(ls_curr_path)
'ChDrive ls_drive
'ChDir ls_curr_path
'ls_output_file = ls_curr_path & "\" & ActiveSheet.Name & ".test.sql"
ls_output_file = "D:\CIS\Projects\temp_sql" & "\" & ActiveSheet.Name & ".test.sql"
ls_output_file = Application.GetSaveAsFilename(ls_output_file, _
"SQL files (*.sql), *.sql", 1, "Save as SQL file")
If Trim(ls_output_file) = "False" Then
Set fso = Nothing
MsgBox prompt:="Process was aborted.", Buttons:=vbExclamation, Title:="Aborted!"
f_get_file_save_path = False
Exit Function
End If
If Trim(ls_output_file) = "" Then
Set fso = Nothing
f_get_file_save_path = False
Exit Function
End If
Dim li_choice As Integer
If fso.FileExists(ls_output_file) Then
Do While True
li_choice = MsgBox(prompt:="File already exists! " & Chr(13) & _
"Press " & Chr(13) & _
" Yes to overwrite it, " & Chr(13) & _
" No to choose another name, " & Chr(13) & _
" Cancel to abort." _
, Buttons:=vbCritical + vbYesNoCancel + vbDefaultButton1 _
, Title:="File already exists!" _
)
If li_choice = vbNo Then
ls_output_file = Application.GetSaveAsFilename(ls_output_file, _
"SQL files (*.sql), *.sql", 1, "Save as SQL file")
If Trim(ls_output_file) = "" Or Trim(ls_output_file) = "False" Then
Set fso = Nothing
MsgBox prompt:="Process was aborted.", Buttons:=vbExclamation, Title:="Aborted!"
f_get_file_save_path = False
Exit Function
End If
End If
If li_choice = vbCancel Then
Set fso = Nothing
MsgBox prompt:="Process was aborted.", Buttons:=vbExclamation, Title:="Aborted!"
f_get_file_save_path = False
Exit Function
End If
If li_choice = vbYes Then
Exit Do
End If
Loop
End If
gs_saved_path = fso.GetParentFolderName(ls_output_file)
Set fso = Nothing
as_output_file = ls_output_file
f_get_file_save_path = True
End Function
Public Sub sub_open_txt_file(ByVal as_file As String)
Dim lo_wsh As New WshSHell
Dim ls_default_app As String
Dim ls_app_path As String
Dim ls_shell_str As String
On Error Resume Next
ls_default_app = lo_wsh.RegRead("HKEY_CLASSES_ROOT\.txt\")
ls_app_path = lo_wsh.RegRead("HKEY_CLASSES_ROOT\" & ls_default_app & "\shell\open\Command\")
If Len(Dir(Split(ls_app_path, """")(1))) <= 0 Then
ls_app_path = "D:\99.Software\UltraEdit17\Uedit32.exe %1"
End If
If Len(ls_app_path) <= 0 Then
' MsgBox prompt:=ls_default_app & " not installed!", Buttons:=vbCritical + vbOKOnly, Title:="Error"
' Exit Sub
ls_app_path = "notepad.exe %1"
End If
Dim ls_command As String
ls_command = Application.Substitute(ls_app_path, "%1", as_file)
lo_wsh.exec ls_command
Set lo_wsh = Nothing
End Sub
Public Sub sub_lock_cells()
On Error GoTo 0
Dim lo_range As Range
ActiveSheet.Unprotect
' For Each lo_eacheditrange In AllowEditRanges
' ActiveSheet.Protection.lo_eacheditrange.Delete
' Next
Set lo_range = Selection
If lo_range.Columns.Count > (ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count) Then
Set lo_range = ActiveSheet.Range(ActiveSheet.Cells(lo_range.Row, lo_range.Column) _
, ActiveSheet.Cells(lo_range.Row + lo_range.Rows.Count - 1, ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1))
End If
If lo_range.Rows.Count > (ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count) Then
Set lo_range = ActiveSheet.Range(ActiveSheet.Cells(lo_range.Row, lo_range.Column) _
, ActiveSheet.Cells(ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1, lo_range.Column + lo_range.Columns.Count - 1))
End If
'Cells.Select
'ActiveSheet.Cells.Locked = False
'ActiveSheet.Cells.FormulaHidden = False
lo_range.Locked = True
lo_range.FormulaHidden = False
' If lo_range.Columns.Count = 1 And lo_range.Rows.Count = 1 Then
' Else
' ActiveSheet.Protection.AllowEditRanges.Add Title:="unlock_range", Range:=lo_range
' End If
ActiveSheet.Protect _
DrawingObjects:=True _
, Contents:=True _
, Scenarios:=True _
, AllowFormattingCells:=True _
, AllowFormattingColumns:=True _
, AllowFormattingRows:=True _
, AllowInsertingColumns:=True _
, AllowInsertingRows:=True _
, AllowInsertingHyperlinks:=True _
, AllowSorting:=True _
, AllowFiltering:=True
End Sub
Public Sub sub_unlock_cells()
On Error GoTo 0
ActiveSheet.Unprotect
Dim lo_range As Range
Set lo_range = Selection
If lo_range.Address = Cells.Address Then
lo_range.Locked = False
lo_range.FormulaHidden = False
Exit Sub
End If
If lo_range.Columns.Count > (ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count) Then
Set lo_range = ActiveSheet.Range(ActiveSheet.Cells(lo_range.Row, lo_range.Column) _
, ActiveSheet.Cells(lo_range.Row + lo_range.Rows.Count - 1, ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1))
End If
If lo_range.Rows.Count > (ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count) Then
Set lo_range = ActiveSheet.Range(ActiveSheet.Cells(lo_range.Row, lo_range.Column) _
, ActiveSheet.Cells(ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1, lo_range.Column + lo_range.Columns.Count - 1))
End If
'Cells.Select
lo_range.Locked = False
lo_range.FormulaHidden = False
' For Each lo_eacheditrange In AllowEditRanges
' ActiveSheet.Protection.lo_eacheditrange.Delete
' Next
'Selection.Locked = True
'Selection.FormulaHidden = False
' If lo_range.Columns.Count = 1 And lo_range.Rows.Count = 1 Then
' Else
' ActiveSheet.Protection.AllowEditRanges.Add Title:="unlock_range", Range:=lo_range
' End If
ActiveSheet.Protect _
DrawingObjects:=True _
, Contents:=True _
, Scenarios:=True _
, AllowFormattingCells:=True _
, AllowFormattingColumns:=True _
, AllowFormattingRows:=True _
, AllowInsertingColumns:=True _
, AllowInsertingRows:=True _
, AllowInsertingHyperlinks:=True _
, AllowSorting:=True _
, AllowFiltering:=True
End Sub
Public Sub sub_lock()
Dim lo_range As Range
ActiveSheet.Unprotect
For Each lo_eacheditrange In AllowEditRanges
ActiveSheet.Protection.lo_eacheditrange.Delete
Next
Set lo_range = Selection
If lo_range.Columns.Count = 1 And lo_range.Rows.Count = 1 Then
Else
ActiveSheet.Protection.AllowEditRanges.Add Title:="unlock_range", Range:=lo_range
End If
ActiveSheet.Protect _
DrawingObjects:=True _
, Contents:=True _
, Scenarios:=True _
, AllowFormattingCells:=True _
, AllowFormattingColumns:=True _
, AllowFormattingRows:=True _
, AllowInsertingColumns:=True _
, AllowInsertingRows:=True _
, AllowInsertingHyperlinks:=True _
, AllowSorting:=True _
, AllowFiltering:=True
End Sub
Public Sub sub_unlock()
Dim lo_range As Range
ActiveSheet.Unprotect
For Each lo_eacheditrange In AllowEditRanges
ActiveSheet.Protection.lo_eacheditrange.Delete
Next
Exit Sub
Set lo_range = Selection
If lo_range.Columns.Count = 1 And lo_range.Rows.Count = 1 Then
Else
ActiveSheet.Protection.AllowEditRanges.Add Title:="unlock_range", Range:=lo_range
End If
ActiveSheet.Protect _
DrawingObjects:=True _
, Contents:=True _
, Scenarios:=True _
, AllowFormattingCells:=True _
, AllowFormattingColumns:=True _
, AllowFormattingRows:=True _
, AllowInsertingColumns:=True _
, AllowInsertingRows:=True _
, AllowInsertingHyperlinks:=True _
, AllowSorting:=True _
, AllowFiltering:=True
End Sub
Public Sub sub_gen_insert_sql_bak()
Dim ls_table_name As String
Dim ls_table_summary As String
ls_table_name = Trim(ActiveSheet.Name)
ls_table_summary = "Summary"
On Error Resume Next
If Worksheets("Summary").Name = "" Then
MsgBox "There should be sheet of a table summary first, " & Chr(13) & _
"and its name should be " & """" & "Summary" & """" & "."
Exit Sub
End If
On Error GoTo 0
If ActiveSheet.Name = ls_table_summary Then
MsgBox "Please choose a table sheet other than the summary sheet."
Exit Sub
End If
Dim ll_valid_data_max_col As Long
ll_valid_data_max_col = f_get_valid_data_max_col(ActiveSheet)
Dim lo_each_row
Dim lo_each_col
Dim ls_blank_row_flag As String
ls_blank_row_flag = "Y"
For Each lo_each_row In Selection.Rows
For lo_each_col = 1 To ll_valid_data_max_col
If Len(Trim(ActiveSheet.Cells(lo_each_row.Row, lo_each_col))) > 0 Then
ls_blank_row_flag = "N"
Exit For
End If
Next
Next
If ls_blank_row_flag = "Y" Then
MsgBox "You selected blank row(s)! Please select valid row(s) first!"
Exit Sub
End If
If Selection.Row = 1 And Selection.Rows.Count = 1 Then
MsgBox "You selected invalid row!"
Exit Sub
End If
Dim ls_output_file As String
If Not f_get_file_save_path(ls_output_file) Then Exit Sub
'get summary data, and keep table-row-from and table-row-to
Dim larr_table_summary
larr_table_summary = Worksheets(ls_table_summary).Range("B1:B" & Worksheets(ls_table_summary).UsedRange.Rows.Count)
Dim larr_db
larr_db = Worksheets(ls_table_summary).Range("A1:A" & Worksheets(ls_table_summary).UsedRange.Rows.Count)
Dim ll_each_row As Long
Dim ldct_table_row_from As New Dictionary
Dim ldct_table_row_to As New Dictionary
For ll_each_row = 1 To UBound(larr_table_summary, 1)
If Not ldct_table_row_from.Exists(larr_table_summary(ll_each_row, 1)) Then
ldct_table_row_from.Add larr_table_summary(ll_each_row, 1), ll_each_row
End If
If Not ldct_table_row_to.Exists(larr_table_summary(ll_each_row, 1)) Then
ldct_table_row_to(larr_table_summary(ll_each_row, 1)) = ll_each_row
Else
'if a table appears in another DB, then ignore it.
If larr_db(ll_each_row, 1) = larr_db(ldct_table_row_from.Item(larr_table_summary(ll_each_row, 1)), 1) Then
ldct_table_row_to(larr_table_summary(ll_each_row, 1)) = ll_each_row
End If
End If
Next
Dim ll_table_row_from As Long
Dim ll_table_row_to As Long
Dim li_column_num As Integer
ll_table_row_from = ldct_table_row_from(ls_table_name)
ll_table_row_to = ldct_table_row_to(ls_table_name)
li_column_num = ll_table_row_to - ll_table_row_from + 1
Dim larr_columns
larr_columns = Worksheets(ls_table_summary).Range("D" & ll_table_row_from & ":D" & ll_table_row_to)
'column type
Dim larr_col_type
larr_col_type = Worksheets(ls_table_summary).Range("E" & ll_table_row_from & ":E" & ll_table_row_to)
Dim ldct_col_type As New Dictionary
For ll_each_row = 1 To li_column_num
ldct_col_type.Add larr_columns(ll_each_row, 1), larr_col_type(ll_each_row, 1)
Next
'delete key columns
Dim larr_del_key_col
larr_del_key_col = Worksheets(ls_table_summary).Range("J" & ll_table_row_from & ":J" & ll_table_row_to)
Dim ldct_del_key_col As New Dictionary
For ll_each_row = 1 To li_column_num
If UCase(larr_del_key_col(ll_each_row, 1)) = "Y" Then
ldct_del_key_col.Add larr_columns(ll_each_row, 1), ll_each_row
End If
Next
'the max row of the data in this sheet
Dim ll_valid_data_max_row As Long
ll_valid_data_max_row = f_get_valid_data_max_row(ActiveSheet)
Dim li_each_col As Integer
Dim ls_col_value 'As String
Dim ls_col_name As String
Dim ls_col_type As String
Dim ll_blank_cnt As Integer
Dim ls_values
Dim ls_ins_sql_each_row
'Dim lo_each_row
'check if the table structure are consistent
For li_each_col = 1 To li_column_num
If larr_columns(li_each_col, 1) <> ActiveSheet.Cells(1, li_each_col) Then
MsgBox "The column order is NOT same as the one in sheet " & ls_table_summary & Chr(13) & _
"Please re-order the columns first."
Exit Sub
End If
Next
Dim lo_output As New ADODB.Stream
lo_output.Type = 2
lo_output.Charset = "ASCII"
lo_output.Open
Dim ldct_del_where_clause As New Dictionary
If ldct_del_key_col.Count > 0 Then
Dim ls_delete_table As String
Dim ls_each_del_sql As String
'generate the delete table_name
ls_delete_table = "delete from " & ls_table_name
lo_output.WriteText ls_delete_table, adWriteLine
lo_output.WriteText " where ", adWriteChar
For Each lo_each_row In Selection.Rows
ll_each_row = lo_each_row.Row
If ll_each_row = 1 Then GoTo continue_next_for1
If ll_each_row > ll_valid_data_max_row Then Exit For
'ldct_del_where_clause.RemoveAll
ls_each_del_sql = "("
ll_blank_cnt = 0
For li_each_col = 0 To ldct_del_key_col.Count - 1
ls_col_name = ldct_del_key_col.Keys(li_each_col)
ls_col_type = ldct_col_type(ls_col_name)
ls_col_value = Trim(ActiveSheet.Cells(ll_each_row, ldct_del_key_col.Items(li_each_col)))
' If Not ldct_del_where_clause.Exists(ls_col_value) Then
' ldct_del_where_clause.Add ls_col_value, "1"
If IsEmpty(ls_col_value) Or IsNull(ls_col_value) Or ls_col_value = "" Then
ls_col_value = ls_col_name & " is null"
ll_blank_cnt = ll_blank_cnt + 1
ElseIf ls_col_value = "NULL" Then
ls_col_value = ls_col_name & " is null"
ll_blank_cnt = ll_blank_cnt + 1
Else
If InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "NUMBER", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "FLOAT", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "LONG", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "INTEGER", vbTextCompare) > 0 Then
'do nothing
ElseIf InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col + 1))), "DATE", vbTextCompare) > 0 Then
ls_col_value = ls_col_name & " = " & "to_date('" & Format(ls_col_value, "MM/dd/yyyy hh:mm:ss") & "', 'MM/dd/yyyy hh24:mi:ss')"
Else
ls_col_value = ls_col_name & " = " & "'" & ls_col_value & "'"
End If
End If
If li_each_col = 0 Then
ls_each_del_sql = ls_each_del_sql & ls_col_value
Else
ls_each_del_sql = ls_each_del_sql & " and " & ls_col_value
End If
' End If
Next
ls_each_del_sql = ls_each_del_sql & ")"
If ll_blank_cnt = ldct_del_key_col.Count Then
Else
If Not ldct_del_where_clause.Exists(ls_each_del_sql) Then
ldct_del_where_clause(ls_each_del_sql) = "Y"
If ll_each_row = Selection.Row Then
lo_output.WriteText ls_each_del_sql, adWriteLine
Else
lo_output.WriteText " or " & ls_each_del_sql, adWriteLine
End If
End If
End If
continue_next_for1:
Next
lo_output.WriteText ";", adWriteLine
lo_output.WriteText "", adWriteLine
End If
'generate the insert into table_name (col1, col2, ....) values (
Dim ls_ins_table
ls_ins_table = "insert into " + ls_table_name + " ("
For li_each_col = 1 To li_column_num
ls_col_name = Trim(ActiveSheet.Cells(1, li_each_col).Text)
If li_each_col = li_column_num Then
ls_ins_table = ls_ins_table + ls_col_name
Else
ls_ins_table = ls_ins_table + ls_col_name + ", "
End If
Next
ls_ins_table = ls_ins_table + ")" & Chr(13) & Chr(10) & "values ("
'insert sql
For Each lo_each_row In Selection.Rows
ll_each_row = lo_each_row.Row
If ll_each_row = 1 Then GoTo continue_next_for2
If ll_each_row > ll_valid_data_max_row Then Exit For
ls_values = ""
ls_ins_sql_each_row = ""
ll_blank_cnt = 0
For li_each_col = 1 To li_column_num
ls_col_value = Trim(ActiveSheet.Cells(ll_each_row, li_each_col))
If IsEmpty(ls_col_value) Or IsNull(ls_col_value) Or ls_col_value = "" Then
ls_col_value = "NULL"
ll_blank_cnt = ll_blank_cnt + 1
ElseIf ls_col_value = "NULL" Then
Else
If InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "NUMBER", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "FLOAT", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "LONG", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "INTEGER", vbTextCompare) > 0 Then
'do nothing
ElseIf InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "DATE", vbTextCompare) > 0 Then
If UCase(ls_col_value) = "SYSDATE" Then
Else
ls_col_value = "to_date('" & Format(ls_col_value, "MM/dd/yyyy hh:mm:ss") & "', 'MM/dd/yyyy hh24:mi:ss')"
End If
Else
ls_col_value = "'" & ls_col_value + "'"
End If
End If
If li_each_col = li_column_num Then
ls_values = ls_values & ls_col_value
Else
ls_values = ls_values & ls_col_value + ", "
End If
Next
If ll_blank_cnt = ldct_del_key_col.Count Then
Else
If ll_blank_cnt = li_column_num Then
Else
ls_ins_sql_each_row = ls_ins_table & ls_values + ");"
lo_output.WriteText ls_ins_sql_each_row, adWriteLine
End If
End If
continue_next_for2:
Next
lo_output.WriteText "", adWriteLine
lo_output.WriteText "commit;", adWriteLine
lo_output.SaveToFile ls_output_file, 2
lo_output.Close
Set lo_output = Nothing
Call sub_open_txt_file(ls_output_file)
Set ldct_col_type = Nothing
End Sub
Public Function f_get_valid_data_max_row(ByVal ao_activesheet As Worksheet) As Long
Dim ll_excel_max_row As Long
ll_excel_max_row = ao_activesheet.Cells.Rows.Count
Dim ll_used_max_col As Long
ll_used_max_col = ao_activesheet.UsedRange.Column + ao_activesheet.UsedRange.Columns.Count - 1
Dim ll_each_col As Long
Dim ll_max_row_saved As Long
Dim ll_max_row_each_col As Long
ll_max_row_saved = 0
For ll_each_col = 1 To ll_used_max_col
ll_max_row_each_col = ao_activesheet.Cells(ll_excel_max_row, ll_each_col).End(xlUp).Row
If ll_max_row_each_col > ll_max_row_saved Then ll_max_row_saved = ll_max_row_each_col
Next
f_get_valid_data_max_row = ll_max_row_saved
End Function
Public Function f_get_valid_data_max_col(ByVal ao_activesheet As Worksheet) As Long
Dim ll_excel_max_col As Long
ll_excel_max_col = ao_activesheet.Cells.Columns.Count
Dim ll_used_max_row As Long
ll_used_max_row = ao_activesheet.UsedRange.Row + ao_activesheet.UsedRange.Rows.Count - 1
Dim ll_each_row As Long
Dim ll_max_col_saved As Long
Dim ll_max_col_each_row As Long
ll_max_col_saved = 0
For ll_each_row = 1 To ll_used_max_row
ll_max_col_each_row = ao_activesheet.Cells(ll_each_row, ll_excel_max_col).End(xlToLeft).Column
If ll_max_col_each_row > ll_max_col_saved Then ll_max_col_saved = ll_max_col_each_row
Next
f_get_valid_data_max_col = ll_max_col_saved
End Function
Public Function f_SortArray(ByRef arr)
Dim I As Integer, Temp As Variant
Dim OK As Boolean
Do
OK = True
For I = UBound(arr) To 2 Step -1
If arr(I - 1) > arr(I) Then
Temp = arr(I - 1)
arr(I - 1) = arr(I)
arr(I) = Temp
OK = False
End If
Next I
Loop Until OK
'f_SortArray = arr
End Function
Public Sub sub_OpenFile(ByVal as_file_name As String)
Dim Result As Long
Result = ShellExecute(0&, vbNullString, as_file_name, _
vbNullString, vbNullString, vbNormalFocus)
If Result < 32 Then MsgBox "File open Error:" & as_file_name
End Sub
Public Function f_if_sheet_exists(ByVal as_sheet_name As String)
Dim lo_each_sheet As Worksheet
'For Each lo_each_sheet In ao_workbook.Worksheets
For Each lo_each_sheet In ThisWorkbook.Worksheets
If LCase(Trim(lo_each_sheet.Name)) = LCase(Trim(as_sheet_name)) Then
f_if_sheet_exists = True
Exit Function
End If
Next
f_if_sheet_exists = False
End Function
Public Sub Sort_Sheets()
Dim sCount As Integer, I As Integer, r As Integer
Dim JH
ReDim Na(1) As String
sCount = Sheets.Count
For I = 1 To sCount
ReDim Preserve Na(I) As String
Na(I) = Sheets(I).Name
Next
For I = 1 To sCount - 1
For r = I + 1 To sCount
If Na(r) < Na(I) Then
JH = Na(I)
Na(I) = Na(r)
Na(r) = JH
End If
Next
Next
For I = 1 To sCount
Sheets(Na(I)).Move After:=Sheets(I)
Next
End Sub
Module_CommandBar.bas
----------------------------
Attribute VB_Name = "Module_CommandBar"
Option Explicit
Sub sub_add_new_bar(as_bar_name As String)
Dim lcb_new_commdbar As CommandBar
Call sub_RemoveToolBar(as_bar_name)
Set lcb_new_commdbar = Application.CommandBars.Add(as_bar_name, msoBarTop)
lcb_new_commdbar.Visible = True
End Sub
Public Sub sub_RemoveToolBar(as_toolbar As String)
On Error Resume Next
Dim lcb_commdbar As CommandBar
Set lcb_commdbar = Nothing
Application.CommandBars(as_toolbar).Delete
Application.CommandBars("Custom 1").Delete
End Sub
Sub sub_remove_all_bars()
On Error Resume Next
Dim tempbar As CommandBar
For Each tempbar In Application.CommandBars
'If tempbar.Name Like "my_bar*" Then
tempbar.Delete
'End If
Next
End Sub
Public Sub sub_add_new_button(as_bar_name As String, as_btn_caption As String, _
as_on_action As String, ai_face_id As Integer, _
Optional as_tip_text As String)
Dim lcb_commdbar As CommandBar
Dim lbtn_new_button As CommandBarButton
Set lcb_commdbar = Application.CommandBars(as_bar_name)
Set lbtn_new_button = lcb_commdbar.Controls.Add(msoControlButton)
With lbtn_new_button
.Caption = as_btn_caption
.Style = msoButtonIconAndCaptionBelow
'.OnAction = "sub_RemoveToolBar"
.OnAction = as_on_action
.FaceId = ai_face_id
.TooltipText = as_tip_text
.BeginGroup = True
End With
'Set lcb_commdbar = Nothing
'Set lbtn_new_button = Nothing
End Sub
Module_Toolbar4.bas
---------------------------------------
Attribute VB_Name = "Module_Toolbar4"
Option Explicit
'MySQL configuration
'Const gs_odbc_driver = "MySql ODBC 5.3 Unicode Driver"
'Const gs_server_ip = "127.0.0.1"
'Const gs_uid = "root"
'Const gs_pwd = "1234"
'Const gs_database = "richard_db"
'oracle
'Const gs_odbc_driver = "MySql ODBC 5.3 Unicode Driver"
'Const gs_server_ip = "127.0.0.1"
'Const gs_uid = "root"
'Const gs_pwd = "1234"
'Const gs_database = "richard_db"
'or
Const Oracle_Conn_String = "driver={microsoft odbc for oracle};server=prod;uid=xx;pwd=xx"
'Const Oracle_Conn_String = "Provider=MSDAORA.1;Data Source=dl580;User ID=xx;Password=xx;Persist Security Info=True"
'Const Oracle_Conn_String = "provider=msdaora;Data Source=xx;User Id=xx;Password=xx"
'Const Oracle_Conn_String = "Provider=OraOLEDB.Oracle;Data Source=xx;User ID=xx;password=xx"
'这儿的Data Source (DL580)是oracle客户端配置的网络服务名称，配置放在tnsnames.ora文件中，如：
'DL580 =
' (DESCRIPTION =
' (ADDRESS_LIST =
' (ADDRESS = (PROTOCOL = TCP)(HOST = 130.81.100.136)(PORT = 1521))
' )
' (CONNECT_DATA =
' (SERVICE_NAME = orcl)
' )
' )
Const gs_select = "select * from "
Const gs_where_clause = ""
Public go_Conn As ADODB.Connection
Public go_Records As ADODB.Recordset
Public gb_db_connected As Boolean
Option Base 1
Public Sub sub_retrieve_data()
If f_connect_db() < 0 Then
MsgBox Err.Description
Exit Sub
End If
Dim ls_table_name As String
If ActiveSheet.Name = gs_summary_sheet Then
If ActiveCell.Row <= 1 Then
MsgBox "you selected the wrong line!"
Exit Sub
End If
ls_table_name = ThisWorkbook.ActiveSheet.Cells(ActiveCell.Row, COL_TABLE_NAME)
Else
ls_table_name = ActiveSheet.Name
End If
If f_query_data(ls_table_name) < 0 Then
'MsgBox Err.Description
Exit Sub
End If
' If f_disconnect_db() < 0 Then
' MsgBox Err.Description
' Exit Sub
' End If
MsgBox "Done! checck sheet [" & ls_table_name & "]!"
End Sub
Function f_connect_db()
If gb_db_connected Then
f_connect_db = 1
Exit Function
End If
Dim mysql_ConnStr As String '定义连接字符串
'mysql
mysql_ConnStr = "Driver={" & gs_odbc_driver & "};" _
& "server=" & gs_server_ip & ";" _
& "uid=" & gs_uid & ";" _
& "pwd=" & gs_pwd & ";" _
& "DATABASE=" & gs_database & ";"
' "Option=3"
If go_Conn Is Nothing Then
Set go_Conn = New ADODB.Connection '定义ADODB连接对象
End If
If go_Conn.State <> adStateOpen Then
'mysql
'go_Conn.Open mysql_ConnStr
'oracle
go_Conn.Open Oracle_Conn_String
If go_Conn.State = adStateOpen Then
'MsgBox "connection to DB succeeeded."
gb_db_connected = True
Set go_Records = New ADODB.Recordset
Else
gb_db_connected = False
MsgBox "Sorry. Connection Failed"
End If
End If
'MSDASQL: ole -> odbc, so odbc name should be provided as below
' mysql_ConnStr = "Provider=MSDASQL;" _
' & "Server=localhost;" _
' & "Uid=root;" _
' & "Pwd=1234;" _
' & "Data Source=odbc_richard_db"
'
'this one requires MySQL ole drvier be installed.
'ConnStr = "Provider=OleMySql.MySqlSource.1;Server=localhost;Database=richard_db;Uid=root;Pwd=1234"
'ConnStr = "Provider=OleMySql.MySqlSource.1;Location=localhost;Data Source=richard_db;User Id=root;Password=1234;"
' "Provider=OleMySql.MySqlSource.1; " _
' & " Data Source=localhost,3306; Initial Catalog=test", _
' "root", "myPassword"
'ConnStr = "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.FullName
'oraoledb.oracle.1
'"Provider=OraOLEDB.Oracle.1;Persist Security Info=True;User ID=iqms;Password=iqms;Data Source=iqora"
'CnStr = "PROVIDER=MSDAORA.1;Password=" & DbPw & ";User ID=" & DbUser & ";Data Source=" & FileName & ";Persist Security Info=True"
'CnStr = "PROVIDER=MSDataShape;Data PROVIDER=MSDASQL;uid=" & DbUser & ";pwd=" & DbPw & ";DRIVER=SQL Server;DATABASE=" & DbName & ";WSID=GQSOFT;SERVER=" & DbIP
'ConnStr = "Provider=sqloledb;server=localhost;uid=root;pwd=1234;Data Source=richard_db"
'ConnStr = "Provider=MSDASQL.1;Persist Security Info=True;User ID=root;Data Source=odbc_richard_db;DSN=odbc_richard_db;UID=root;pwd=1234"
End Function
Function f_query_data(ByVal as_table As String)
If Not if_TableExist(as_table) Then
f_query_data = -1
MsgBox "Table " & as_table & " does not exist!"
Exit Function
End If
Dim ls_SQLStr As String '要执行的SQL语句
ls_SQLStr = gs_select & " " & as_table & " " & gs_where_clause
'Dim lo_Records As New ADODB.Recordset '定义ADODB对象的记录集
go_Records.Open ls_SQLStr, go_Conn ', adOpenStatic, adLockBatchOptimistic '读取SQL查询结果到Records记录集
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Function
End If
'Records.Open
Dim I, j, TotalRows, TotalColumns As Integer
j = 0
TotalRows = go_Records.RecordCount
TotalColumns = go_Records.Fields.Count
'下面的循环把表头（即列名）写到Excel表的第一行
' For I = 0 To TotalColumns - 1
' Sheet.Cells(1, I + 1) = lo_Records.Fields(I).Name
' Next
Dim lo_sheet As Worksheet
If f_if_sheet_exists(as_table) Then
Else
Dim ll_tab_start_row As Long
Dim ll_tab_end_row As Long
ll_tab_start_row = f_get_tab_1st_row(ActiveCell.Row)
ll_tab_end_row = f_get_tab_last_row(ActiveCell.Row)
If f_create_link_for_table(ll_tab_start_row, ll_tab_end_row) < 0 Then
MsgBox "Error, please check f_query_data!"
Exit Function
End If
End If
Set lo_sheet = ThisWorkbook.Worksheets(as_table)
lo_sheet.Cells(2, 1).Resize(f_get_valid_data_max_row(lo_sheet), f_get_valid_data_max_col(lo_sheet)).Clear
lo_sheet.Cells(2, 1).CopyFromRecordset go_Records
'下面的循环把查询结果写到Excel表中
' Do While Not go_Records.EOF
'
' For I = 0 To TotalColumns - 1
' lo_sheet.Cells(j + 2, I + 1) = go_Records.Fields(I).Value
' Next
'
' go_Records.MoveNext
' j = j + 1
' Loop
go_Records.Close '关闭记录集
'Set lo_Records = Nothing '清空对象
End Function
Public Function f_disconnect_db()
If gb_db_connected Then
'go_Records.Close '关闭记录集
go_Conn.Close '关闭连接
Set go_Records = Nothing '清空对象
Set go_Conn = Nothing '清空对象
gb_db_connected = False
End If
End Function
Private Function if_TableExist(ByVal sTable As String) As Boolean
Dim rs As ADODB.Recordset
Set rs = go_Conn.OpenSchema(adSchemaTables)
While (Not rs.EOF)
If UCase(rs("table_name")) = UCase(sTable) Then
if_TableExist = True
rs.Close
Set rs = Nothing
Exit Function
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
End Function
Module_Toolbar2.bas
--------------------------------------
Attribute VB_Name = "Module_Toolbar2"
Option Explicit
Option Base 1
Public Sub sub_gen_insert_sql()
Dim ls_table_name As String
Dim ls_table_summary As String
ls_table_name = Trim(ActiveSheet.Name)
ls_table_summary = "Summary"
On Error Resume Next
If Worksheets("Summary").Name = "" Then
MsgBox "There should be sheet of a table summary first, " & Chr(13) & _
"and its name should be " & """" & "Summary" & """" & "."
Exit Sub
End If
On Error GoTo 0
If ActiveSheet.Name = ls_table_summary Then
MsgBox "Please choose a table sheet other than the summary sheet."
Exit Sub
End If
Dim ll_valid_data_max_col As Long
ll_valid_data_max_col = f_get_valid_data_max_col(ActiveSheet)
'the max row of the data in this sheet
Dim ll_valid_data_max_row As Long
ll_valid_data_max_row = f_get_valid_data_max_row(ActiveSheet)
Dim lo_each_row
Dim lo_each_col
Dim lo_each_area
Dim ls_blank_row_flag As String
ls_blank_row_flag = "Y"
For Each lo_each_area In Selection.Areas
For Each lo_each_row In lo_each_area.Rows
If lo_each_row.Row = 1 Then GoTo continue_next_row1
If lo_each_row.Row > ll_valid_data_max_row Then GoTo continue_next_area1
For lo_each_col = 1 To ll_valid_data_max_col
If Len(Trim(ActiveSheet.Cells(lo_each_row.Row, lo_each_col))) > 0 Then
ls_blank_row_flag = "N"
GoTo blank_invalid_error
End If
Next
continue_next_row1:
Next
continue_next_area1:
Next
blank_invalid_error:
If ls_blank_row_flag = "Y" Then
MsgBox "You selected blank/invalid row(s)! Please select valid row(s) first!"
Exit Sub
End If
' If Selection.Row = 1 And Selection.Rows.Count = 1 Then
' MsgBox "You selected invalid row!"
' Exit Sub
' End If
Dim ls_output_file As String
If Not f_get_file_save_path(ls_output_file) Then Exit Sub
'get summary data, and keep table-row-from and table-row-to
Dim larr_table_summary
larr_table_summary = Worksheets(ls_table_summary).Range("B1:B" & Worksheets(ls_table_summary).UsedRange.Rows.Count)
Dim larr_db
larr_db = Worksheets(ls_table_summary).Range("A1:A" & Worksheets(ls_table_summary).UsedRange.Rows.Count)
Dim ll_each_row As Long
Dim ldct_table_row_from As New Dictionary
Dim ldct_table_row_to As New Dictionary
For ll_each_row = 1 To UBound(larr_table_summary, 1)
If Not ldct_table_row_from.Exists(larr_table_summary(ll_each_row, 1)) Then
ldct_table_row_from.Add larr_table_summary(ll_each_row, 1), ll_each_row
End If
If Not ldct_table_row_to.Exists(larr_table_summary(ll_each_row, 1)) Then
ldct_table_row_to(larr_table_summary(ll_each_row, 1)) = ll_each_row
Else
'if a table appears in another DB, then ignore it.
If larr_db(ll_each_row, 1) = larr_db(ldct_table_row_from.Item(larr_table_summary(ll_each_row, 1)), 1) Then
ldct_table_row_to(larr_table_summary(ll_each_row, 1)) = ll_each_row
End If
End If
Next
Dim ll_table_row_from As Long
Dim ll_table_row_to As Long
Dim li_column_num As Integer
ll_table_row_from = ldct_table_row_from(ls_table_name)
ll_table_row_to = ldct_table_row_to(ls_table_name)
li_column_num = ll_table_row_to - ll_table_row_from + 1
Dim larr_columns
larr_columns = Worksheets(ls_table_summary).Range("D" & ll_table_row_from & ":D" & ll_table_row_to)
'column type
Dim larr_col_type
larr_col_type = Worksheets(ls_table_summary).Range("E" & ll_table_row_from & ":E" & ll_table_row_to)
Dim ldct_col_type As New Dictionary
For ll_each_row = 1 To li_column_num
ldct_col_type.Add larr_columns(ll_each_row, 1), larr_col_type(ll_each_row, 1)
Next
'delete key columns
Dim larr_del_key_col
larr_del_key_col = Worksheets(ls_table_summary).Range("J" & ll_table_row_from & ":J" & ll_table_row_to)
Dim ldct_del_key_col As New Dictionary
For ll_each_row = 1 To li_column_num
If UCase(larr_del_key_col(ll_each_row, 1)) = "Y" Then
ldct_del_key_col.Add larr_columns(ll_each_row, 1), ll_each_row
End If
Next
Dim li_each_col As Integer
Dim ls_col_value 'As String
Dim ls_col_name As String
Dim ls_col_type As String
Dim ll_blank_cnt As Integer
Dim ls_values
Dim ls_ins_sql_each_row
'Dim lo_each_row
'check if the table structure are consistent
For li_each_col = 1 To li_column_num
If larr_columns(li_each_col, 1) <> ActiveSheet.Cells(1, li_each_col) Then
MsgBox "The column order is NOT same as the one in sheet " & ls_table_summary & Chr(13) & _
"Please re-order the columns first."
Exit Sub
End If
Next
Dim larr_selected_rows()
Dim li_i As Long
Dim ldct_row_recorder As New Dictionary
For Each lo_each_area In Selection.Areas
For Each lo_each_row In lo_each_area.Rows
If lo_each_row.Row = 1 Then GoTo continue_next_row2
If lo_each_row.Row > ll_valid_data_max_row Then GoTo continue_next_area2
If ldct_row_recorder.Exists(lo_each_row.Row) Then GoTo continue_next_row2
li_i = li_i + 1
ReDim Preserve larr_selected_rows(li_i)
larr_selected_rows(li_i) = lo_each_row.Row
ldct_row_recorder.Add lo_each_row.Row, 0
continue_next_row2:
Next
continue_next_area2:
Next
Call f_SortArray(larr_selected_rows)
Dim ll_each_item As Long
Dim lo_output As New ADODB.Stream
lo_output.Type = 2
lo_output.Charset = "ASCII"
lo_output.Open
Dim ldct_del_where_clause As New Dictionary
If ldct_del_key_col.Count > 0 Then
Dim ls_delete_table As String
Dim ls_each_del_sql As String
'generate the delete table_name
ls_delete_table = "delete from " & ls_table_name
lo_output.WriteText ls_delete_table, adWriteLine
lo_output.WriteText " where ", adWriteChar
For ll_each_item = 1 To UBound(larr_selected_rows)
ll_each_row = larr_selected_rows(ll_each_item)
'ldct_del_where_clause.RemoveAll
ls_each_del_sql = "("
ll_blank_cnt = 0
For li_each_col = 0 To ldct_del_key_col.Count - 1
ls_col_name = ldct_del_key_col.Keys(li_each_col)
ls_col_type = ldct_col_type(ls_col_name)
'ls_col_value = Trim(ActiveSheet.Cells(ll_each_row, ldct_del_key_col.Items(li_each_col)))
ls_col_value = ActiveSheet.Cells(ll_each_row, ldct_del_key_col.Items(li_each_col))
' If Not ldct_del_where_clause.Exists(ls_col_value) Then
' ldct_del_where_clause.Add ls_col_value, "1"
If IsEmpty(ls_col_value) Or IsNull(ls_col_value) Or ls_col_value = "" Then
ls_col_value = ls_col_name & " is null"
ll_blank_cnt = ll_blank_cnt + 1
ElseIf ls_col_value = "NULL" Then
ls_col_value = ls_col_name & " is null"
ll_blank_cnt = ll_blank_cnt + 1
Else
' If InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "NUMBER", vbTextCompare) > 0 _
' Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "FLOAT", vbTextCompare) > 0 _
' Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "LONG", vbTextCompare) > 0 _
' Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col) + 1))), "INTEGER", vbTextCompare) > 0 Then
If InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col)))), "NUMBER", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col)))), "FLOAT", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col)))), "LONG", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, ldct_del_key_col.Items(li_each_col)))), "INTEGER", vbTextCompare) > 0 Then
'do nothing
' MsgBox "test"
ElseIf InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col + 1))), "DATE", vbTextCompare) > 0 Then
ls_col_value = ls_col_name & " = " & "to_date('" & Format(ls_col_value, "MM/dd/yyyy hh:mm:ss") & "', 'MM/dd/yyyy hh24:mi:ss')"
Else
ls_col_value = ls_col_name & " = " & "'" & ls_col_value & "'"
End If
End If
If li_each_col = 0 Then
ls_each_del_sql = ls_each_del_sql & ls_col_value
Else
ls_each_del_sql = ls_each_del_sql & " and " & ls_col_value
End If
' End If
Next
ls_each_del_sql = ls_each_del_sql & ")"
If ll_blank_cnt = ldct_del_key_col.Count Then
Else
If Not ldct_del_where_clause.Exists(ls_each_del_sql) Then
ldct_del_where_clause(ls_each_del_sql) = "Y"
If ll_each_row = larr_selected_rows(1) Then
lo_output.WriteText ls_each_del_sql, adWriteLine
Else
lo_output.WriteText " or " & ls_each_del_sql, adWriteLine
End If
End If
End If
Next
lo_output.WriteText ";", adWriteLine
lo_output.WriteText "", adWriteLine
End If
'generate the insert into table_name (col1, col2, ....) values (
Dim ls_insert_into
ls_insert_into = "insert into " + ls_table_name + " ("
For li_each_col = 1 To li_column_num
ls_col_name = Trim(ActiveSheet.Cells(1, li_each_col).Text)
If li_each_col = li_column_num Then
ls_insert_into = ls_insert_into + ls_col_name
Else
ls_insert_into = ls_insert_into + ls_col_name + ", "
End If
Next
ls_insert_into = ls_insert_into + ")" & Chr(13) & Chr(10) & "values ("
'insert sql
For ll_each_item = 1 To UBound(larr_selected_rows)
ll_each_row = larr_selected_rows(ll_each_item)
ls_values = ""
ls_ins_sql_each_row = ""
ll_blank_cnt = 0
For li_each_col = 1 To li_column_num
'ls_col_value = Trim(ActiveSheet.Cells(ll_each_row, li_each_col))
ls_col_value = ActiveSheet.Cells(ll_each_row, li_each_col)
If IsEmpty(ls_col_value) Or IsNull(ls_col_value) Or ls_col_value = "" Then
ls_col_value = "NULL"
ll_blank_cnt = ll_blank_cnt + 1
ElseIf ls_col_value = "NULL" Then
ls_col_value = "NULL"
Else
If InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "NUMBER", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "FLOAT", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "LONG", vbTextCompare) > 0 _
Or InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "INTEGER", vbTextCompare) > 0 Then
'do nothing
ElseIf InStr(1, ldct_col_type(Trim(ActiveSheet.Cells(1, li_each_col))), "DATE", vbTextCompare) > 0 Then
If UCase(ls_col_value) = "SYSDATE" Then
Else
ls_col_value = "to_date('" & Format(ls_col_value, "MM/dd/yyyy hh:mm:ss") & "', 'MM/dd/yyyy hh24:mi:ss')"
End If
Else
ls_col_value = "'" & ls_col_value + "'"
End If
End If
If li_each_col = li_column_num Then
ls_values = ls_values & ls_col_value
Else
ls_values = ls_values & ls_col_value + ", "
End If
Next
If ll_blank_cnt = li_column_num Then
Else
ls_ins_sql_each_row = ls_insert_into & ls_values + ")" & Chr(13) & Chr(10) & ";"
lo_output.WriteText ls_ins_sql_each_row, adWriteLine
End If
Next
lo_output.WriteText "", adWriteLine
lo_output.WriteText "commit;", adWriteLine
lo_output.SaveToFile ls_output_file, 2
lo_output.Close
Set lo_output = Nothing
Call sub_open_txt_file(ls_output_file)
Set ldct_col_type = Nothing
End Sub
Module_CommandBar.bas
-------------------------------------------
Attribute VB_Name = "Module_CommandBar"
Option Explicit
Sub sub_add_new_bar(as_bar_name As String)
Dim lcb_new_commdbar As CommandBar
Call sub_RemoveToolBar(as_bar_name)
Set lcb_new_commdbar = Application.CommandBars.Add(as_bar_name, msoBarTop)
lcb_new_commdbar.Visible = True
End Sub
Public Sub sub_RemoveToolBar(as_toolbar As String)
On Error Resume Next
Dim lcb_commdbar As CommandBar
Set lcb_commdbar = Nothing
Application.CommandBars(as_toolbar).Delete
Application.CommandBars("Custom 1").Delete
End Sub
Sub sub_remove_all_bars()
On Error Resume Next
Dim tempbar As CommandBar
For Each tempbar In Application.CommandBars
'If tempbar.Name Like "my_bar*" Then
tempbar.Delete
'End If
Next
End Sub
Public Sub sub_add_new_button(as_bar_name As String, as_btn_caption As String, _
as_on_action As String, ai_face_id As Integer, _
Optional as_tip_text As String)
Dim lcb_commdbar As CommandBar
Dim lbtn_new_button As CommandBarButton
Set lcb_commdbar = Application.CommandBars(as_bar_name)
Set lbtn_new_button = lcb_commdbar.Controls.Add(msoControlButton)
With lbtn_new_button
.Caption = as_btn_caption
.Style = msoButtonIconAndCaptionBelow
'.OnAction = "sub_RemoveToolBar"
.OnAction = as_on_action
.FaceId = ai_face_id
.TooltipText = as_tip_text
.BeginGroup = True
End With
'Set lcb_commdbar = Nothing
'Set lbtn_new_button = Nothing
End Sub
295
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
