worksheet 的代码
Const SourceFiledConfigStart As Integer = 2Const SourceFiledConfigEnd As Integer = 27Const SourceFiledDefaultStart As Integer = 41Const SourceFiledDefaultEnd As Integer = 46Const usersheetname As String = "数据"Const RefSheetname As String = "配置"Public sourcefilename As StringPublic sourcefilepath As StringDim index_Col As IntegerDim SUBPATH As ObjectDim FieldExists As BooleanDim TargetColumnArray() As StringDim SourceColumnArray() As StringPrivate Function CopyField(index_Object As Integer, index_Source As Integer) Dim iColumnIndex As Integer iColumnIndex = index_Source - 1 ActiveWorkbook.Sheets(1).Range("A2").Select Selection.Offset(0, iColumnIndex).Select ActiveWorkbook.Sheets(1).Range(Selection, Selection.End(xlDown)).Select Selection.Copy ThisWorkbook.Activate Sheets(usersheetname).Select Sheets(usersheetname).Range("A2").Select iColumnIndex = index_Object - 1 Selection.Offset(0, iColumnIndex).Select ActiveSheet.PasteEnd Function '用于记录源表列名所在的列Private Function CopyField2(index_Object As Integer, index_Source As Integer) Dim row As Integer Dim iRows As Integer iRows = ActiveWorkbook.Sheets(1).Cells(1, index_Source).CurrentRegion.Rows.Count '列拷贝 For row = 2 To iRows ThisWorkbook.Sheets(usersheetname).Cells(row, index_Object) = ActiveWorkbook.Sheets(1).Cells(row, index_Source).Value() Next row End FunctionPrivate Function IndexCol(colName As String) Dim iColumns As Integer Dim column As Integer iColumns = ActiveWorkbook.Sheets(1).UsedRange.Columns.Count For column = 1 To iColumns If ActiveWorkbook.Sheets(1).Cells(1, column) = colName Then index_Col = column Exit For End If Next column End FunctionPrivate Function DataSheetClear() '清除第二行开始的数据 Dim rowstart As Integer Dim iColumns As Integer rowend = Sheets(usersheetname).UsedRange.Rows.Count rowstart = 2 If rowend < 2 Then Exit Function End If Sheets(usersheetname).Range("A" & rowstart, "A" & rowend).EntireRow.DeleteEnd FunctionFunction ExcelColumnNameConvert(ByVal r)If r Like "[A-Z]*" Then ExcelColumnNameConvert = Range(r & 1).columnIf r Like "#*" And r > 0 And r <= 256 Then ExcelColumnNameConvert = Split(Cells(1, r).Address, "$")(1)End FunctionPrivate Function SetField(index_Object As Integer, defaultValue As Integer) Dim iRows As Integer Dim AString As String Dim AString2 As String Dim AString3 As String Dim AStartRow As Integer iRows = ThisWorkbook.Sheets(usersheetname).Cells(1, index_Object).CurrentRegion.Rows.Count AString = ExcelColumnNameConvert(index_Object) AStartRow = 2 AString2 = AString & AStartRow AString3 = AString & iRows AString = AString2 & ":" & AString3 ThisWorkbook.Activate Sheets(usersheetname).Select Sheets(usersheetname).Range(AString2).Select ActiveCell.FormulaR1C1 = defaultValue Selection.AutoFill Destination:=Sheets(usersheetname).Range(AString), Type:=xlFillDefaultEnd FunctionPrivate Function SetField2(index_Object As Integer, defaultValue As Integer) Dim row As Integer Dim iRows As Integer iRows = ThisWorkbook.Sheets(usersheetname).Cells(1, index_Object).CurrentRegion.Rows.Count '列拷贝 For row = 2 To iRows ThisWorkbook.Sheets(usersheetname).Cells(row, index_Object) = defaultValue Next row End FunctionPrivate Function SetDefaultFieldData() For iRow = SourceFiledDefaultStart To SourceFiledDefaultEnd Call SetField(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9), ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 2)) NextEnd FunctionPrivate Function CopyFieldData() Set SUBPATH = CreateObject("vbscript.regexp") With SUBPATH .Global = True .Pattern = ".*\\" End With sourcefilepath = ThisWorkbook.Sheets(RefSheetname).Cells(1, 5) soucefilename = SUBPATH.Replace(sourcefilepath, "") FileExists = Exist(soucefilename) If Not FileExists Then Workbooks.Open sourcefilepath End If Windows(soucefilename).Activate For iRow = SourceFiledConfigStart To SourceFiledConfigEnd Windows(soucefilename).Activate Call CopyField(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9), ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 3)) NextEnd FunctionPrivate Function GetTargetColumns() Dim iCount As Integer Dim strValue As String Dim str As String Set SUBPATH = CreateObject("vbscript.regexp") With SUBPATH .Global = True .Pattern = ".*\\" End With ThisWorkbook.Activate If ThisWorkbook.Sheets(RefSheetname).Cells(1, 5) = "" Then MsgBox "没有选择Excel文件", vbOKOnly, "配置错误" Exit Function End If sourcefilepath = ThisWorkbook.Sheets(RefSheetname).Cells(1, 5) soucefilename = SUBPATH.Replace(sourcefilepath, "") FileExists = Exist(soucefilename) If Not FileExists Then Workbooks.Open sourcefilepath End If Windows(soucefilename).Activate iCount = ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Columns.Count strValue = "" str = "" For iColumn = 1 To iCount - 1 str = Trim(ActiveWorkbook.Sheets(1).Cells(1, iColumn).Value) strValue = strValue + str + "," Next strValue = strValue + Trim(ActiveWorkbook.Sheets(1).Cells(1, iCount).Value) InitCandidateValue (strValue) TargetColumnArray = Split(strValue, ",")End FunctionPrivate Sub CommandButton1_Click() Dim FileExists As Boolean FieldExists = Flase '清除基站信息检测模板数据和检测报告 Call DataSheetClear Call GetTargetColumns '处理数据 FieldExists = CheckTargetFields If Not FieldExists Then MsgBox "目标文件检查失败" Exit Sub End If FieldExists = CheckSourceFields If Not FieldExists Then MsgBox "本文件数据sheet检查失败" Exit Sub End If Sheets(RefSheetname).Select MsgBox "检查完成"End SubPrivate Function CheckSourceFields() As Boolean Dim iRow As Integer Dim iFieldIndex As Integer Dim sFieldName As String Dim iCols As Integer Dim iCol As Integer Dim errFields As String Dim errMSG As String errMSG = "" errFields = "" getProjectDColumn For iRow = SourceFiledConfigStart To SourceFiledConfigEnd For iFieldIndex = 0 To UBound(SourceColumnArray) sFieldName = SourceColumnArray(iFieldIndex) If sFieldName = Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1)) Then ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9) = iFieldIndex + 1 Exit For End If Next If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9)) = "" Then errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " " End If Next For iRow = SourceFiledDefaultStart To SourceFiledDefaultEnd For iFieldIndex = 0 To UBound(SourceColumnArray) sFieldName = SourceColumnArray(iFieldIndex) If sFieldName = Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1)) Then ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9) = iFieldIndex + 1 Exit For End If Next If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9)) = "" Then errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " " End If Next If errFields <> "" Then ThisWorkbook.Activate errMSG = "工程参数表对应列名： " & errFields & "不存在，请检查输入是否正确！" MsgBox errMSG, vbOKOnly, "字段配置错误" CheckSourceFields = False Else CheckSourceFields = True End If End FunctionPrivate Sub CommandButton2_Click() Dim filename As Variant '打开文件对话框返回的文件名，是一个全路径文件名，其值也可能是False，因此类型为Variant Dim sFileName As String '从FileName中提取的文件名 Dim sPathName As String '从FileName中提取的路径名 Dim aFile As Variant Dim values As String filename = Application.GetOpenFilename("Excel 文件,*.xls;*.xlsx") Call DataSheetClear '调用Windows打开文件对话框 If filename <> False Then '如果未按“取消”键 aFile = Split(filename, "\") '在全路径中，以“\”为分隔符，分成数据 sPathName = aFile(0) '取盘符 For i = 1 To UBound(aFile) - 1 '循环合成路径名 sPathName = sPathName & "\" & aFile(i) Next sFileName = aFile(UBound(aFile)) '数组的最后一个元素为文件名 Cells(1, 5).Value = sPathName & "\" & sFileName '保存路径名 FileExists = Exist(sFileName) If Not FileExists Then Workbooks.Open filename End If Windows(sFileName).Activate values = getColumnValue(sFileName, filename) InitCandidateValue (values) ThisWorkbook.Activate MsgBox "文件选择完成" Else MsgBox "文件选择失败" Exit Sub End IfEnd SubPrivate Function CheckTargetFields() As Boolean Dim iRow As Integer Dim iFieldIndex As Integer Dim sFieldName As String Dim iCols As Integer Dim iCol As Integer Dim errFields As String Dim errMSG As String errMSG = "" errFields = "" For iRow = SourceFiledConfigStart To SourceFiledConfigEnd If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 2)) = "" Then errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " " End If For iFieldIndex = 0 To UBound(TargetColumnArray) sFieldName = TargetColumnArray(iFieldIndex) If sFieldName = Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 2)) Then ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 3) = iFieldIndex + 1 Exit For End If Next If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 3)) = "" Then errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " " End If Next If errFields <> "" Then ThisWorkbook.Activate errMSG = "源表对应列名： " & errFields & "不存在，请检查输入是否正确！" MsgBox errMSG, vbOKOnly, "字段配置错误" CheckTargetFields = False Else CheckTargetFields = True End If End FunctionPrivate Function Exist(ByVal filename As String) As Boolean Dim iCount As Integer Dim i As Integer iCount = Workbooks.Count For i = 1 To iCount If Workbooks.Item(i).Name = filename Then Exist = True Exit For End If Next If i > iCount Then Exist = False End If End FunctionPrivate Function getProjectDColumn() As String Dim strValue As String Dim str As String Dim iCount As Integer Dim iColumn As Integer 'Windows(sFileName).Activate iCount = ThisWorkbook.Sheets(usersheetname).Cells(1, 1).CurrentRegion.Columns.Count strValue = "" str = "" For iColumn = 1 To iCount - 1 str = Trim(ThisWorkbook.Sheets(usersheetname).Cells(1, iColumn).Value) strValue = strValue + str + "," Next str = Trim(ThisWorkbook.Sheets(usersheetname).Cells(1, iCount).Value) strValue = strValue + str SourceColumnArray = Split(strValue, ",") iCount = UBound(TargetColumnArray) getProjectDColumn = strValueEnd FunctionPrivate Function getColumnValue(ByVal sFileName As String, ByVal filename As String) As String Dim strValue As String Dim str As String Dim iCount As Integer Dim iColumn As Integer FileExists = Exist(sFileName) If Not FileExists Then Workbooks.Open filename End If Windows(sFileName).Activate 'Windows(sFileName).Activate iCount = ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Columns.Count strValue = "" str = "" For iColumn = 1 To iCount - 1 str = Trim(ActiveWorkbook.Sheets(1).Cells(1, iColumn).Value) strValue = strValue + str + "," Next str = Trim(ActiveWorkbook.Sheets(1).Cells(1, iCount).Value) strValue = strValue + str TargetColumnArray = Split(strValue, ",") iCount = UBound(TargetColumnArray) getColumnValue = strValue End FunctionPublic Function InitCandidateValue(ByVal values As String) ThisWorkbook.Activate Sheets(RefSheetname).Select Range("D2:D100").Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=values .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End With End FunctionPrivate Sub CommandButton3_Click() ' 复制数据开始了 Call DataSheetClear Call CopyFieldData Call SetDefaultFieldDataEnd SubThisWorkBook的代码
Const usersheetname As String = "数据"Const RefSheetname As String = "配置"Private Sub Workbook_Open() If Sheets(RefSheetname).Cells(1, 5).Value = "" Then Sheets(RefSheetname).InitCandidateValue (" ") Sheets(RefSheetname).Range("D2:D100").ClearContents Sheets(RefSheetname).Select End IfEnd Sub
