EXCEL VBA 程序备忘

'将AWS相关位置内容幅值到WWD相关位置
'Excel.Application.Workbooks.Open("D:\WWD.xlsx").Worksheets(1).Cells(19, 1).Value = Excel.Application.Workbooks.Open("D:\AWS.xlsx").Worksheets(1).Cells(1, 1)

'将对应位置的EXCEL的对应单元格内容读取至当前单元格
Sheets(3).Cells(15, 1).Value = GetObject(Worksheets("window").Cells(14, 1)).Worksheets(1).Cells(1, 1)

举例说明：在Sht1的13,1单元格输出Sht1的16,5所在单元格地址，如果是合并单元格则返回合并单元格地址。

Sub Onecode()

Worksheets("Sht1").Cells(13, 1).Value = Worksheets("Sht1").Cells(16, 5).MergeArea.Address  '输出合并单元格地址

Worksheets("Sht1").Cells(14, 1).Value = Left(Worksheets("Sht1").Cells(16, 5).MergeArea.Address, 5)  '输出值的左5位数

Worksheets("Sht1").Cells(15, 1).Value = Worksheets("Sht1").Cells(16, 5).MergeArea.Cells(1, 1)  '输出合并单元格内首格值

Worksheets("Sht1").Cells(16, 1).Value = Worksheets("Sht1").Cells(16, 5).MergeArea.Count         '输出合并单元格包含格数

Worksheets("Sht1").Cells(18, 1).Value = Worksheets("Sht1").Cells(16, 5).MergeArea.Rows.Count     '返回合并单元格列长度

Worksheets("Sht1").Cells(19, 1).Value = Worksheets("Sht1").Cells(16, 5).MergeArea.Columns.Count  '返回合并单元格列数

Worksheets("Sht1").Cells(20, 1).Value = Worksheets("Sht1").Cells(16, 5).MergeArea.Value         '输出合并单元格内容
End Sub

'HSI转换使用 搜索条件是表二的需求，返回表二引脚对应的需求对应的function

'HSI转换使用     搜索条件是表二的需求，返回表二引脚对应的需求对应的function
Sub Mycode()

Dim Sheet1Long As Integer '此字符设置需要搜寻表1的行数，主要用于确定对比引脚号
Dim webLong As Integer      '此字符设置需要搜寻表2的行数，主要用于需要填充的引脚号做搜寻
Dim func As Byte '0-255,设置表一功能数
Dim func2 As Byte '0-255,设置表二需求功能数

'需要配置的参数：
Dim Sheet1Long_Limit As Integer                                 '此字符设置需要搜寻表1的行数，主要用于确定对比引脚号
Sheet1Long_Limit = 7  '限制表一的引脚数量
Dim webLong_Limit As Integer                                    '此字符设置需要搜寻表2的行数，主要用于需要填充的引脚号做搜寻
webLong_Limit = 7    '限制表二的引脚数量  应该必须和表一一致
Dim func_Limit As Byte                                          '0-255,设置表一功能数
func_Limit = 7    '限制表一的功能功能
Dim func2_Limit As Byte                                         '0-255,设置表二需求功能数
func2_Limit = 7    '限制表二的分类数量

Dim S1_Star_location As Byte
S1_Star_location = 0    '设置表一功能的起始位置，注意完整起始位置是  S2_Star_location + func2 * Sheet2Step_Size  ，乘以了一个步进长度，所以最小为 步进长度
Dim S2_Star_location As Byte
S2_Star_location = 0    '设置表二功能的起始位置，注意完整起始位置是  S2_Star_location + func2 * Sheet2Step_Size  ，乘以了一个步进长度，所以最小为 步进长度

Dim Sheet1Step_Size As Byte
Sheet1Step_Size = 2    '限制表一功能的步进长度
Dim Sheet2Step_Size As Byte
Sheet2Step_Size = 2    '限制表二分类的步进长度

Dim S1_Star As Byte
S1_Star = 2    '设置表一的开始行
Dim S2_Star As Byte
S2_Star = 2    '设置表二的开始行

Dim S1 As String
S1 = "Sht1"  '设置表一名称
Dim S2 As String
S2 = "wed"    '设置表二名称
'需要配置的参数结束


For webLong = S2_Star To webLong_Limit         '设置表二搜寻引脚数量
    'If Worksheets("Sheet1").Cells(webLong, 1).Value <> "" Then Exit For  '如果表二出现空格则退出此次循环
    For Sheet1Long = S1_Star To Sheet1Long_Limit        '设置对表1的排查数量，必须确保表一表二对比数量相同
        'If Worksheets("wed").Cells(Sheet1Long, 1).Value <> "" Then Exit For      '如果对比到空白单元格退出当前循环
        If Worksheets(S2).Cells(webLong, 1).Value = Worksheets(S1).Cells(Sheet1Long, 1).Value Then    '判断表二首列引脚所在表一的行
            For func2 = 1 To func2_Limit     '对7条需求功能排查
                Worksheets(S2).Cells(webLong, func2 * 2).Value = ""  '把需要填写的格子清楚掉，其他单元格不影响
                For func = 1 To func_Limit    '对7条需求功能排查
                    If Worksheets(S2).Cells(1, S2_Star_location + func2 * Sheet2Step_Size).Value <> "" Then   '表二的条件不为空
                        If InStr(1, Worksheets(S1).Cells(Sheet1Long, S1_Star_location + func * Sheet1Step_Size).Value, Worksheets(S2).Cells(1, S2_Star_location + func2 * Sheet2Step_Size).Value) Then '判断表二的首行判断字符是否被包含在表一的function中
                            Worksheets(S2).Cells(webLong, S2_Star_location + func2 * Sheet2Step_Size).Value = Worksheets(S2).Cells(webLong, S2_Star_location + func2 * Sheet2Step_Size).Value & Chr(10) & Worksheets(S1).Cells(Sheet1Long, S1_Star_location + func * Sheet1Step_Size).Value '满足条件赋值
                        End If
                    End If
                Next
            Next
        End If
    Next
Next
End Sub

EXECL文件管理程序，制作中

Sub AASA()

Dim filename As String
Dim file_Path As String
Dim Path As String
Dim i As Byte

i = 1
file_Path = "D:\入职\"


filename = Dir(file_Path)  '可以更改为任意文件夹
Worksheets("window").Cells(i, 1).Value = filename
Do While filename <> ""
    i = i + 1
    filename = Dir()  '获取下一个文件名
    Worksheets("window").Cells(i, 1).Value = filename
Loop

'Workbooks.Open "D:\入职\HRM常见问题清单.xlsx"
VBA.CreateObject("Wscript.Shell").Run ("D:\入职\VDI使用指南.docx")  '打开指定路径的指定文件
'Application.GetOpenFilename ("D:\入职\VDI使用指南.docx")   '方式有问题暂时打不开
End Sub



'Sub 打开文件()   '参考程序
'    sPath = Excel.ThisWorkbook.Path & "\"
'    Set obj = VBA.CreateObject("Wscript.Shell")
'    '打开同路径下的jpg文件
'    obj.Run (sPath & "1.jpg")
'     '打开同路径下的pdf文件
'    obj.Run (sPath & "test.pdf")
'     '打开同路径下的doc文件
'    obj.Run (sPath & "apple.doc")
'     '打开同路径下的xlsx文件
'    obj.Run (sPath & "abc.xlsx")
'End Sub

5、BOM对比筛选工具

'HSI转换使用     搜索条件表1的两列条件返回表2内容
Sub Mycode()

Dim t As String

For j = 3 To 306
Worksheets("A1").Cells(j, 7).Clear
Worksheets("A1").Cells(j, 8).Clear
    For i = 3 To 341
        If Worksheets("A1").Cells(j, 4).Value <> "" Then
            If InStr(1, Worksheets("B").Cells(i, 2).Value, Worksheets("A1").Cells(j, 4).Value) Then
                If InStr(1, Worksheets("B").Cells(i, 2).Value, Worksheets("A1").Cells(j, 5).Value) Then
                    If Worksheets("A1").Cells(j, 7).Value = "" Then
                        Worksheets("A1").Cells(j, 7).Value = Worksheets("B").Cells(i, 2).Value
                    Else
                        Worksheets("A1").Cells(j, 7).Value = Worksheets("A1").Cells(j, 7).Value & Chr(10) & Worksheets("B").Cells(i, 2).Value
                    End If
                    
                    If Worksheets("A1").Cells(j, 8).Value = "" Then
                        Worksheets("A1").Cells(j, 8).Value = Worksheets("B").Cells(i, 3).Value
                    Else
                        Worksheets("A1").Cells(j, 8).Value = Worksheets("A1").Cells(j, 8).Value & Chr(10) & Worksheets("B").Cells(i, 3).Value
                    End If
                End If
            End If
        End If
    Next
Next
End Sub