|
|
2#
楼主 |
发表于 2025-8-29 11:33:35
|
只看该作者
本帖最后由 likeyouli 于 2025-11-15 11:28 编辑
再次改进代码，因为当单元格内为日期时，用公式生成后会自动转为数字，导致日期无法分辨，所以必须用text(lie,"yyyy-mm-dd")这种格式
Sub 一键生成3个文件sql和ctl和数据文件导入oracle数据库_最大100列()
Dim oShell As Object, psCommand As String, i As Long, filepath3 As String
'''如果有oracle已建成的表有时间列，则将时间列改为： DATE "YYYY-MM-DD" NULLIF 费用发生时间=BLANKS
'''以下当单元格有回车或换行符时使用
''With Application
'' .ScreenUpdating = False
'' .Calculation = xlCalculationManual
'' .EnableEvents = False
'' .StatusBar = "正在去除单元格内回车符和换行符，请稍候..."
'' End With
'' ' 分列处理以避免内存问题
'' For i = 1 To Range("A1").CurrentRegion.Columns.Count
'' On Error GoTo cuowutiaoguo
'' With Columns(i).SpecialCells(xlCellTypeConstants) '当某一列全为公式时会报错，也就时这一列必须有一个单位格为xlCellTypeConstants
'' .Replace What:=Chr(10), Replacement:="", LookAt:=xlPart
'' .Replace What:=Chr(13), Replacement:="", LookAt:=xlPart
'' End With
''cuowutiaoguo:
'' DoEvents ' 防止界面卡死
'' On Error GoTo 0 ' 关闭错误捕获
'' Next i
'' With Application
'' .ScreenUpdating = True
'' .Calculation = xlCalculationAutomatic
'' .EnableEvents = True
'' .StatusBar = False
'' End With
filepath1 = "C:\shengcheng.sql"
filepath2 = "C:\shengcheng.ctl"
filepath3 = "C:\shengcheng.txt"
TableName = InputBox("请输入Oracle表名:", "表名输入", "你的表名")
If Not TableName Like "[a-zA-Z一-龢]*" Then MsgBox "表名不是以字母或汉字开头,请从新开始": Exit Sub
riqilie = InputBox("请输入日期的列名（格式为m;n等字母，用符号分开）:", "列名输入", "a")
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.Pattern = "[a-zA-Z]+" ' 匹配一个或多个数字
End With
'Set matches = regex.Execute(riqilie)
'For Each riqilie1 In matches
' If riqilie1 = "x" Then
' MsgBox 2
' End If
'Next riqilie1
For i = 1 To 100
If Cells(1, i + 1) = "" Then colTypes = colTypes & """""""""" & Cells(1, i) & """""""""" & " varchar2(800)": Exit For
colTypes = colTypes & """""""""" & Cells(1, i) & """""""""" & " varchar2(800)," & vbCrLf
Next i
strText = "set echo on;" & vbCrLf & "CREATE TABLE " & TableName & vbCrLf & "(" & colTypes & ");" & vbCrLf & "commit;" & vbCrLf
Set oShell = CreateObject("WScript.Shell")
psCommand = "powershell -Command " & """$bytes = [System.Text.Encoding]::UTF8.GetBytes('" & strText & "'); " & _
"$stream = [System.IO.File]::Create('" & filepath1 & "'); " & "$stream.Write($bytes, 0, $bytes.Length); " & "$stream.Close()"""
oShell.Run psCommand, 1, True
Set oShell = Nothing
'以上生成仅有create table的sql文件，无insert into语句。
'以下将日期列增加text公式
riqijia = 0
For i = 1 To 100
If riqijia = regex.Execute(riqilie).Count Then riqijia = regex.Execute(riqilie).Count - 1
' On Error Resume Next
riqilie1 = regex.Execute(riqilie)(riqijia)
' On Error GoTo 0
zimu = GetExcelColumnName(i)
If Cells(1, i + 1) = "" And UCase(zimu) = UCase(riqilie1) Then
xx = xx & """'""" & "&" & "text(" & "CLEAN(" & zimu & 2 & "),""yyyy-mm-dd"")" & "&" & """');""": Exit For
Else
If Cells(1, i + 1) = "" Then xx = xx & """'""" & "&" & "CLEAN(" & zimu & 2 & ")&" & """');""": Exit For
End If
If i = 1 Then
xx = xx & """INSERT INTO """ & " &" & """" & TableName & """" & "&" & """ VALUES(""" & "&" & """'""" & "&" & "CLEAN(" & zimu & 2 & ")&" & """'""" & "&" & """,""" & "&"
Else
If UCase(zimu) = UCase(riqilie1) Then
riqijia = riqijia + 1
xx = xx & """'""" & "&" & "text(" & "CLEAN(" & zimu & 2 & "),""yyyy-mm-dd"")" & "&" & """'""" & "&" & """,""" & "&"
Else
xx = xx & """'""" & "&" & "CLEAN(" & zimu & 2 & ")&" & """'""" & "&" & """,""" & "&"
End If
End If
Next i
Cells(2, i + 1).NumberFormatLocal = "G/通用格式"
Cells(2, i + 1) = "=" & xx
h = Range("a1").CurrentRegion.Rows.Count
If h < 5000 Then
Cells(2, i + 1).AutoFill Range(Cells(2, i + 1), Cells(h, i + 1))
Else
h = 50
Cells(2, i + 1).AutoFill Range(Cells(2, i + 1), Cells(h, i + 1))
End If
Range(Cells(2, i + 1), Cells(h, i + 1)).Copy
Set oShell = CreateObject("WScript.Shell")
psCommand = "powershell -Command " & "echo 正粘贴insert into语句，请稍等...; " & _
"Get-Clipboard -TextFormatType UnicodeText | Out-File -Encoding UTF8 -Append '" & filepath1 & "'"""
oShell.Run psCommand, vbNormalFocus, True
Set oShell = Nothing
'以上为粘贴insert into语句，用的append，因为开始生成的为utf-8编码，append不改变编码
Set oShell = CreateObject("WScript.Shell")
psCommand = "powershell -ExecutionPolicy Bypass -Command " & "echo 正往sql文件里和末尾插入commit; " & "$i = 0; " & _
"$sb = [System.Text.StringBuilder]::new(); " & "Get-Content " & filepath1 & " -Encoding UTF8 | ForEach-Object { " & _
" [void]$sb.AppendLine($_); " & " $i++; " & " if ($i % 1000 -eq 0) { [void]$sb.AppendLine('commit;') } " & "}; " & _
"[void]$sb.AppendLine('commit;'); " & "$bytes = [System.Text.Encoding]::UTF8.GetBytes($sb.ToString()); " & _
"$stream = [System.IO.File]::Create('c:\output.sql'); " & "$stream.Write($bytes, 0, $bytes.Length); " & "$stream.Close()"
oShell.Run psCommand, vbNormalFocus, True
Set oShell = Nothing
'以上每隔1000行和末尾插入commit；
xx = ""
For i = 1 To 100
If Cells(1, i + 1) = "" Then xx = xx & """" & Cells(1, i) & """" & " CHAR NULLIF " & """" & Cells(1, i) & """" & "=BLANKS)": Exit For
xx = xx & """" & Cells(1, i) & """" & " CHAR NULLIF " & """" & Cells(1, i) & """" & "=BLANKS," & vbCrLf
Next i
xx1 = "OPTIONS (SKIP=0, ERRORS=10, DIRECT=TRUE, PARALLEL=TRUE)" & vbCrLf & "LOAD DATA" & vbCrLf & _
"INFILE '/home/shengcheng.txt'" & vbCrLf & "APPEND INTO TABLE " & TableName & vbCrLf & "FIELDS TERMINATED BY ""|||!|||""" & _
vbCrLf & "TRAILING NULLCOLS" & vbCrLf & "(" & xx
' 将文本放入剪贴板
With New DataObject
.SetText xx1
.PutInClipboard
End With
Set oShell = CreateObject("WScript.Shell")
psCommand = "powershell -Command " & """$clipboardContent = Get-Clipboard -Raw; " & _
"$bytes = [System.Text.Encoding]::UTF8.GetBytes($clipboardContent); " & _
"$stream = [System.IO.File]::Create('" & filepath2 & "'); " & _
"$stream.Write($bytes, 0, $bytes.Length); " & "$stream.Close()"""
oShell.Run psCommand, 1, True
Set oShell = Nothing
'以上生成的为ctl文件，以下生成数据文件
xx = ""
riqijia = 0
For i = 1 To 100
zimu = GetExcelColumnName(i)
If riqijia = regex.Execute(riqilie).Count Then riqijia = regex.Execute(riqilie).Count - 1
' On Error Resume Next
riqilie1 = regex.Execute(riqilie)(riqijia)
' On Error GoTo 0
If Cells(1, i + 1) = "" And UCase(zimu) = UCase(riqilie1) Then
xx = xx & "text(" & zimu & 2 & ",""yyyy-mm-dd"")": Exit For
Else
If Cells(1, i + 1) = "" Then xx = xx & zimu & 2: Exit For
End If
If UCase(zimu) = UCase(riqilie1) Then
riqijia = riqijia + 1
xx = xx & "text(" & zimu & 2 & ",""yyyy-mm-dd"")" & "&" & """|||!|||""" & "&"
Else
xx = xx & zimu & 2 & "&" & """|||!|||""" & "&" '生成的单元格内容被双引号包裹，费劲千辛万苦测试出来
End If
Next i
Cells(2, i + 1) = "=" & xx
h = Range("a1").CurrentRegion.Rows.Count
Cells(2, i + 1).AutoFill Range(Cells(2, i + 1), Cells(h, i + 1))
Range(Cells(2, i + 1), Cells(h, i + 1)).Copy
Set oShell = CreateObject("WScript.Shell")
psCommand = "powershell -Command " & """echo 正生成ctl对应的大数据文件，数据量较大请稍等...; " & "$clipboardContent = Get-Clipboard -Raw; " & _
"$bytes = [System.Text.Encoding]::UTF8.GetBytes($clipboardContent); " & _
"$stream = [System.IO.File]::Create('" & filepath3 & "'); " & _
"$stream.Write($bytes, 0, $bytes.Length); " & "$stream.Close()"""
oShell.Run psCommand, 1, True
Set oShell = Nothing
CreateObject("WScript.Shell").PopUp "文件已生成到: " & filepath1 & "和" & filepath2 & filepath3, 0, "提示", 64
' MsgBox "文件已生成到: " & filepath1 & "和" & filepath2 & filepath3
'''以上为生成与ctl配套的数据文件
''psCommand = "powershell -command ""(Get-Content '" & filepath3 & "').Length"""
''result = CreateObject("WScript.Shell").exec(psCommand).StdOut.ReadAll
'' Set regex = CreateObject("VBScript.RegExp")
'' With regex
'' .Global = True
'' .Pattern = "\d+" ' 匹配一个或多个数字
'' End With
'' ' Set matches = regex.Execute(result)
'' result1 = regex.Execute(result)(0).Value * 1 '这里必须注意，如果不*1，则用鼠标指向这个变量的时候会看到有双引号（用msgbox弹出看不到，但影响下边的判定是否相等）
' result1 = GetFileLineCountDotNet(filepath3) * 1
result1 = GetFileLineCountSwitch(filepath3) * 1
If h - 1 <> result1 Then
MsgBox "excel单元格内有回车或换行符，请重新操作：" & Chr(13) & "excel有" & h - 1 & "行，而生成的" & filepath3 & "有" & result1 & "行"
Else
MsgBox "恭喜，生成的行数与excle文件的行数相等，均为" & result1 & "行，可放心导入Oracle数据库！！"
End If
End Sub
Function GetExcelColumnName(colNumber As Long) As String
Dim dividend As Long
Dim remainder As Long
Dim columnName As String
dividend = colNumber
columnName = ""
Do While dividend > 0
remainder = (dividend - 1) Mod 26
columnName = Chr(65 + remainder) & columnName ' 65是"A"的ASCII码
dividend = (dividend - remainder - 1) \ 26
Loop
GetExcelColumnName = columnName
End Function
Function GetFileLineCountSwitch(filePath As String) As Long
On Error GoTo ErrorHandler
Dim shell As Object, exec As Object, psCommand As String, result As String
Set shell = CreateObject("WScript.Shell")
' 使用 switch 语句，逐行处理，内存效率高
psCommand = "powershell -command """ & "$count = 0; " & _
"switch -File '" & filePath & "' { default { $count++ } }; " & _
"Write-Output $count" & """"
Set exec = shell.exec(psCommand)
result = Trim(exec.StdOut.ReadAll)
If IsNumeric(result) Then
GetFileLineCountSwitch = CLng(result)
Else
GetFileLineCountSwitch = -1
End If
Exit Function
ErrorHandler:
GetFileLineCountSwitch = -1
End Function
Function GetFileLineCountDotNet(filePath As String) As Long
On Error GoTo ErrorHandler
Dim shell As Object, exec As Object, psCommand As String, result As String
Set shell = CreateObject("WScript.Shell")
' 使用 .NET StreamReader，逐行读取，内存效率最高
psCommand = "powershell -command """ & "$count = 0; " & _
"$reader = New-Object System.IO.StreamReader('" & filePath & "'); " & _
"while ($reader.ReadLine() -ne $null) { $count++ }; " & _
"$reader.Close(); " & "$reader.Dispose(); " & "Write-Output $count" & """"
Set exec = shell.exec(psCommand)
result = Trim(exec.StdOut.ReadAll)
If IsNumeric(result) Then
GetFileLineCountDotNet = CLng(result)
Else
GetFileLineCountDotNet = -1
End If
Exit Function
ErrorHandler:
GetFileLineCountDotNet = -1
End Function
|
|
[复制链接]
IP卡
狗仔卡
发表于 2025-8-29 11:33:23
收藏
支持
反对
提升卡
沉默卡
喧嚣卡
变色卡
千斤顶
显身卡