VBA写excel宏

刺骨的言语ヽ痛彻心扉 2022-08-18 03:25 272阅读 0赞

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

\------------------------------------------------------------------------------------------

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