Excel 文件复制操作vba代码

worksheet 的代码

Const SourceFiledConfigStart As Integer = 2
Const SourceFiledConfigEnd As Integer = 27
Const SourceFiledDefaultStart As Integer = 41
Const SourceFiledDefaultEnd As Integer = 46

Const usersheetname As String = "数据"
Const RefSheetname As String = "配置"

Public sourcefilename As String
Public sourcefilepath As String
Dim index_Col As Integer
Dim SUBPATH As Object
Dim FieldExists As Boolean
Dim TargetColumnArray() As String
Dim SourceColumnArray() As String

Private 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.Paste
End 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 Function

Private 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 Function

Private 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.Delete
End Function

Function ExcelColumnNameConvert(ByVal r)
If r Like "[A-Z]*" Then ExcelColumnNameConvert = Range(r & 1).column
If r Like "#*" And r > 0 And r <= 256 Then ExcelColumnNameConvert = Split(Cells(1, r).Address, "$")(1)
End Function

Private 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:=xlFillDefault
End Function

Private 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 Function

Private Function SetDefaultFieldData()
    For iRow = SourceFiledDefaultStart To SourceFiledDefaultEnd
        Call SetField(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9), ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 2))
    Next
End Function

Private 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))
    Next
End Function

Private 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 Function

Private 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 Sub

Private 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 Function

Private 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 If
End Sub
Private 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 Function

Private 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 Function

Private 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 = strValue
End Function

Private 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 Function

Public 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 Function

Private Sub CommandButton3_Click()
    ' 复制数据开始了
    Call DataSheetClear
    Call CopyFieldData
    Call SetDefaultFieldData
End Sub

ThisWorkBook的代码

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