stData 数据文件,rngConfig 配置文件
Public Function Run(ByRef stData As Worksheet, ByRef rngConfig As Range) As Worksheet
'On Error GoTo Proc_Err
Dim r_Config As Integer, str_ColumnName As String
Dim stNew As Worksheet
'stData.Copy After:=stData
stData.Activate
stData.Parent.Sheets.Add After:=stData
Set stNew = ActiveSheet
stNew.Name = rngConfig.Worksheet.Name
Dim col As Range, errMsg As String, c_new As Integer
c_new = 0
For r_Config = 2 To rngConfig.rows.Count
str_ColumnName = rngConfig.Cells(r_Config, 1)
If str_ColumnName <> "" Then
'MsgBox str_ColumnName
Call myFun.getColumnByName(stData, 1, str_ColumnName, col, errMsg, False)
col.Copy
c_new = c_new + 1
stNew.Activate
stNew.Cells(1, c_new).Select
stNew.Paste
End If
Next r_Config
Exit Function
End Function
以下是函数方法:
Rem 根据关键字,定位行
Public Function getRow(sheet As Worksheet, tag As String, Optional beginRow As Long = 1) As Long
Dim r As Long
With sheet.UsedRange
For r = beginRow To .rows.Count
If .Cells(r, 1).Value = tag Then
getRow = r
Exit Function
End If
Next
End With
getRow = 0
End Function
Rem 根据关键字,定位列
Public Function getColumn(opSheet As Worksheet, headerRow As Long, tag As String) As Integer
Dim c As Integer
Dim msg As String
With opSheet
For c = 1 To .UsedRange.Columns.Count
If .Cells(headerRow, c) = tag Then
getColumn = c
Exit Function
End If
Next
End With
getColumn = 0
End Function
Rem 根据关键字,定位并返回列
Public Function getColumnByName(opSheet As Worksheet, headerRow As Long, tag As String, returnColumn As Range, Optional ByRef errMessage As String, Optional showErrMsg As Boolean = False) As Boolean
getColumnByName = False
Dim c As Integer
c = getColumn(opSheet, headerRow, tag)
If (c = 0) Then
' showErrMsg = True
errMessage = "不能在底表[" & opSheet.Name & "]中定位列[" & tag & "],请查看该文件的格式是否正确!"
If (showErrMsg) Then
MsgBox errMessage, vbInformation, "提示"
End If
Exit Function
Else
Set returnColumn = opSheet.Columns(c)
End If
getColumnByName = True
End Function