Sub zzz()
'
' zzz 宏
'
'
'ActiveWorkbook.Names.Add Name:="S941.群众团体", RefersToR1C1:="=Sheet3!R1C6:R1C6"
'ActiveWorkbook.Names("S941.群众团体").Comment = ""
'ActiveSheet.Cells(1, 1).Value = "HYTX4"
For i = 2 To 443
m = ActiveSheet.Cells(i, 4).Value '获取行业投向三级
j1 = 0
For j = 2 To 1076
n = ActiveSheet.Cells(j, 6).Value '获取行业投向四级
If Mid(m, 1, 4) = Mid(n, 1, 4) Then
j1 = j1 + 1
Else
If j1 <> 0 Then
Exit For
End If
End If
Next j
If j1 <> 0 Then
j2 = j - j1
'If j <> 1076 Then
j = j - 1
'End If
o = "=Sheet3!R" & j2 & "C6:R" & j & "C6"
ActiveSheet.Cells(1, 1).Value = m
ActiveSheet.Cells(2, 1).Value = n
ActiveSheet.Cells(3, 1).Value = o
ActiveSheet.Cells(4, 1).Value = j
ActiveSheet.Cells(5, 1).Value = j1
ActiveWorkbook.Names.Add Name:=m, RefersToR1C1:=o
End If
Next i
End Sub
---------------------------------------------------------------------------------
Sub bbb()
'
' bbb 宏
j = 0
For i = 3 To 30
m = Sheet1.Cells(i, 1).Value '获取机构号
j = j + 1
k = i + 1
n = Sheet1.Cells(k, 1).Value '获取机构号
If m <> n Then
Sheets.Add After:=Sheets(Sheets.Count)
Worksheets("Sheet1").Activate
Rows("1:3").Select
Selection.Copy
Sheets(Sheets.Count).Activate
Range("A1").Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
Rows(i - j + 1 & ":" & k - 1).Select
Selection.Copy
Sheets(Sheets.Count).Activate
Range("A3").Select
ActiveSheet.Paste
ActiveSheet.Name = m
j = 0
End If
Next i
End Sub
'
' zzz 宏
'
'
'ActiveWorkbook.Names.Add Name:="S941.群众团体", RefersToR1C1:="=Sheet3!R1C6:R1C6"
'ActiveWorkbook.Names("S941.群众团体").Comment = ""
'ActiveSheet.Cells(1, 1).Value = "HYTX4"
For i = 2 To 443
m = ActiveSheet.Cells(i, 4).Value '获取行业投向三级
j1 = 0
For j = 2 To 1076
n = ActiveSheet.Cells(j, 6).Value '获取行业投向四级
If Mid(m, 1, 4) = Mid(n, 1, 4) Then
j1 = j1 + 1
Else
If j1 <> 0 Then
Exit For
End If
End If
Next j
If j1 <> 0 Then
j2 = j - j1
'If j <> 1076 Then
j = j - 1
'End If
o = "=Sheet3!R" & j2 & "C6:R" & j & "C6"
ActiveSheet.Cells(1, 1).Value = m
ActiveSheet.Cells(2, 1).Value = n
ActiveSheet.Cells(3, 1).Value = o
ActiveSheet.Cells(4, 1).Value = j
ActiveSheet.Cells(5, 1).Value = j1
ActiveWorkbook.Names.Add Name:=m, RefersToR1C1:=o
End If
Next i
End Sub
---------------------------------------------------------------------------------
Sub bbb()
'
' bbb 宏
j = 0
For i = 3 To 30
m = Sheet1.Cells(i, 1).Value '获取机构号
j = j + 1
k = i + 1
n = Sheet1.Cells(k, 1).Value '获取机构号
If m <> n Then
Sheets.Add After:=Sheets(Sheets.Count)
Worksheets("Sheet1").Activate
Rows("1:3").Select
Selection.Copy
Sheets(Sheets.Count).Activate
Range("A1").Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
Rows(i - j + 1 & ":" & k - 1).Select
Selection.Copy
Sheets(Sheets.Count).Activate
Range("A3").Select
ActiveSheet.Paste
ActiveSheet.Name = m
j = 0
End If
Next i
End Sub
------------------------------------------------------------------------------------------
Sub CTL()
D_TABLE = Trim(ActiveSheet.Cells(1, 5))
FILE_PATH = Trim(ActiveSheet.Cells(2, 14))
If FILE_PATH = "" Then
FILE_PATH = "E:\vba-test\SP_" + D_TABLE + ".txt"
End If
n = ActiveSheet.UsedRange.Rows.Count
Dim FS2
Set FS2 = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set CTL_FILE = FS2.CREATETEXTFILE(FILE_PATH, True)
S_TABLE = Trim(ActiveSheet.Cells(1, 3))
PROC_START = "create or REPLACE procedure " + D_TABLE + "(IN ETLDATE VARCHAR(8),--业务日期" + vbCrLf + "OUT O_RETURN NUMERIC--返回值"
PROC_START = PROC_START + vbCrLf + vbTab + "INSERT INTO" + D_TABLE + "(" + vbCrLf + vbTab + vbTab
CTL_FILE.WRITELINE (PROC_START)
For I = 4 To n
PROC = ""
D_ZD = Trim(ActiveSheet.Cells(I, 5))
D_COMMENT = Trim(ActiveSheet.Cells(I, 6))
If I = n Then
PROC = vbTab + vbTab + vbTab + vbTab + D_ZD + " --" + D_COMMENT
Else
PROC = vbTab + vbTab + vbTab + vbTab + D_ZD + ",--" + D_COMMENT
End If
CTL_FILE.WRITELINE (PROC)
Next
CTL_FILE.WRITELINE (vbCrLf + ")" + vbCrLf + vbTab + vbTab + "SELECT" + vbCrLf + vbTab + vbTab)
For I = 4 To n
PROC = ""
S_ZD = Trim(ActiveSheet.Cells(I, 1))
S_COMMENT = Trim(ActiveSheet.Cells(I, 2))
If I = n Then
PROC = vbTab + vbTab + vbTab + vbTab + S_ZD + ",--" + S_COMMENT
Else
PROC = vbTab + vbTab + vbTab + vbTab + S_ZD + ",--" + S_COMMENT
End If
CTL_FILE.WRITELINE (PROC)
Next
CTL_FILE.WRITELINE (vbCrLf + vbTab + vbTab + "FROM " + S_TABLE)
CTL_FILE.Close
MsgBox ("文件" + FILE_PATH + " 创建完毕")
End Sub
D_TABLE = Trim(ActiveSheet.Cells(1, 5))
FILE_PATH = Trim(ActiveSheet.Cells(2, 14))
If FILE_PATH = "" Then
FILE_PATH = "E:\vba-test\SP_" + D_TABLE + ".txt"
End If
n = ActiveSheet.UsedRange.Rows.Count
Dim FS2
Set FS2 = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set CTL_FILE = FS2.CREATETEXTFILE(FILE_PATH, True)
S_TABLE = Trim(ActiveSheet.Cells(1, 3))
PROC_START = "create or REPLACE procedure " + D_TABLE + "(IN ETLDATE VARCHAR(8),--业务日期" + vbCrLf + "OUT O_RETURN NUMERIC--返回值"
PROC_START = PROC_START + vbCrLf + vbTab + "INSERT INTO" + D_TABLE + "(" + vbCrLf + vbTab + vbTab
CTL_FILE.WRITELINE (PROC_START)
For I = 4 To n
PROC = ""
D_ZD = Trim(ActiveSheet.Cells(I, 5))
D_COMMENT = Trim(ActiveSheet.Cells(I, 6))
If I = n Then
PROC = vbTab + vbTab + vbTab + vbTab + D_ZD + " --" + D_COMMENT
Else
PROC = vbTab + vbTab + vbTab + vbTab + D_ZD + ",--" + D_COMMENT
End If
CTL_FILE.WRITELINE (PROC)
Next
CTL_FILE.WRITELINE (vbCrLf + ")" + vbCrLf + vbTab + vbTab + "SELECT" + vbCrLf + vbTab + vbTab)
For I = 4 To n
PROC = ""
S_ZD = Trim(ActiveSheet.Cells(I, 1))
S_COMMENT = Trim(ActiveSheet.Cells(I, 2))
If I = n Then
PROC = vbTab + vbTab + vbTab + vbTab + S_ZD + ",--" + S_COMMENT
Else
PROC = vbTab + vbTab + vbTab + vbTab + S_ZD + ",--" + S_COMMENT
End If
CTL_FILE.WRITELINE (PROC)
Next
CTL_FILE.WRITELINE (vbCrLf + vbTab + vbTab + "FROM " + S_TABLE)
CTL_FILE.Close
MsgBox ("文件" + FILE_PATH + " 创建完毕")
End Sub