VBA 发运后任务确认表（涉及数据他表引用、指定数据去除、复制指定区域数据、表格保护）

锁匙isthekey

已于 2024-01-18 11:22:35 修改

阅读量107

点赞数

分类专栏： EXCEL 文章标签： excel

于 2023-11-01 14:46:41 首次发布

本文链接：https://blog.csdn.net/weixin_44819434/article/details/134160988

版权

EXCEL 专栏收录该内容

21 篇文章 2 订阅

订阅专栏

按售服部门要求做的一个表格，用于登记发运后设备，现场安装好后确认服务已完成，进行登记

在这里插入图片描述

Sub GetData()
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim myrange As Range
    Dim sheetName As String, path As String
    Dim ws As Worksheet
    Dim i As Integer
    Dim scount As Long, tcount As Long, srow As Long, newcount As Long
    Dim slastrow As Variant, tlastrow As Variant
    Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range

'

'     Worksheets("机床数据").Select
'     Columns("A:J").Select
'     ActiveSheet.Unprotect Password:="chr" '

tcount = ActiveSheet.Range("A1").End(xlDown).Row
tlastrow = ActiveSheet.Range("A" & tcount).Value

'解除保护
'Range("A:I").Select
'Selection.Unprotect

'   path = "\\192.168.100.5\生产中心\生产保障部"
   
   f = Dir(ThisWorkbook.path & "\11#生产任务目录.xlsx")
    If f = "" Then
        MsgBox "源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(ThisWorkbook.path & "\" & f, Password:="chr", ReadOnly:=True)
    End If

    Set sourceWorksheet = sourceWorkbook.Worksheets("4发运")
    
'    如果源工作表有过滤，则显示所有数据
    If sourceWorksheet.FilterMode = True Then
     sourceWorksheet.ShowAllData
    End If
    '源数据最大行数及最大行序号值
    scount = sourceWorksheet.Range("A1").End(xlDown).Row
    slastrow = sourceWorksheet.Range("A" & scount).Value
    
If slastrow > tlastrow Then
    
    '查询目标最大行序号值在源数据中的位置并下移一行
    If tlastrow = "" Then
       srow = 2
       tcount = 1
       Else
       srow = sourceWorksheet.Range("A:A").Find(tlastrow).Cells.Offset(1, 0).Row
    End If
    
    '去除YA和YC机型的任务
     Dim charfind1 As String, charfind2 As String
     charfind1 = "YA"
     charfind2 = "YC"
     For i = scount To srow Step -1
       If InStr(1, UCase(sourceWorksheet.Cells(i, 5).Value), charfind1, vbTextCompare) > 0 Then
            sourceWorksheet.Rows(i).Delete Shift:=xlUp
       End If
       
       If InStr(1, UCase(sourceWorksheet.Cells(i, 5).Value), charfind2, vbTextCompare) > 0 Then
            sourceWorksheet.Rows(i).Delete Shift:=xlUp
       End If
     Next i
 
    
    
    
    '数据源区域
'     Set sourceRange = sourceWorksheet.Range("A1").CurrentRegion '差不多就这个范围，有变化可以修改
    
     Set rng1 = sourceWorksheet.Range("A" & srow & ":C" & scount)
     Set rng2 = sourceWorksheet.Range("E" & srow & ":E" & scount)
     Set rng3 = sourceWorksheet.Range("G" & srow & ":G" & scount)
     Set rng4 = sourceWorksheet.Range("T" & srow & ":T" & scount)
     Set sourceRange = Union(rng1, rng2, rng3, rng4)  '合并多区域

     



    '设置目标工作簿、工作表、范围
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = targetWorkbook.Worksheets("机床数据")
    Set targetRange = targetWorksheet.Range("A" & tcount + 1)

    
    
      
    '复制数据
    sourceRange.Copy targetRange
    
  '    关闭源工作簿，并不保存更改
  sourceWorkbook.Close SaveChanges:=False
    


Worksheets("机床数据").Cells(tcount, 1).Select

'新增数据加边框
newcount = ActiveSheet.Range("A1").End(xlDown).Row
Set myrange = ActiveSheet.Range("A" & tcount + 1 & ":I" & newcount)
' 为区域添加边框
With myrange.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With


'行高
Rows(tcount + 1 & ":" & newcount).Select
Selection.RowHeight = 20

'保护区域
'Columns("A:I").Select
'单元格只读
ActiveSheet.Range("A" & tcount + 1 & ":F" & newcount).Locked = True
ActiveSheet.Protect Password:="chr" '
'
    
      
     
Else

  '    关闭源工作簿，并不保存更改
  sourceWorkbook.Close SaveChanges:=False

  ActiveSheet.Protect Password:="chr" '
  MsgBox "没有新增数据"
  

End If


End Sub

后期取数据方法的改进，不管增加或减少列时，按列名取列号

If slastrow > tlastrow Then
    
    '查询目标最大行序号值在源数据中的位置并下移一行
    If tlastrow = "" Then
       srow = 2
       tcount = 1
       Else
       srow = sourceWorksheet.Range("A:A").Find(tlastrow).Cells.Offset(1, 0).row
    End If

 k = scount - srow + 1
 Dim charfind1 As String, charfind2 As String
 ReDim arr(1 To k, 1 To 6)
 charfind1 = "YA"
 charfind2 = "YC"

 sourceWorksheet.Select
 With sourceWorksheet
'j为目标表最大序号在源表中位置的下一行号，k为新增的行数,l为有效数据的行数
  j = srow
  l = 1
  For i = 1 To k
    If InStr(1, UCase(.Cells(j, 5).Value), charfind1, vbTextCompare) > 0 Or _
     InStr(1, UCase(.Cells(j, 5).Value), charfind2, vbTextCompare) > 0 Then
   GoTo jx
  Else
  
    colnum = 0
    colnum = Application.WorksheetFunction.Match("序号", .Range("A1:Z1"), 0)
    arr(l, 1) = .Cells(j, colnum)
    colnum = 0
    colnum = Application.WorksheetFunction.Match("机床编号", .Range("A1:Z1"), 0)
    arr(l, 2) = .Cells(j, colnum)
    colnum = 0
    colnum = Application.WorksheetFunction.Match("出厂编号", .Range("A1:Z1"), 0)
    arr(l, 3) = .Cells(j, colnum)
    colnum = 0
    colnum = Application.WorksheetFunction.Match("机床型号", .Range("A1:Z1"), 0)
    arr(l, 4) = .Cells(j, colnum)
    colnum = 0
    colnum = Application.WorksheetFunction.Match("客户名称", .Range("A1:Z1"), 0)
    arr(l, 5) = .Cells(j, colnum)
    colnum = 0
    colnum = Application.WorksheetFunction.Match("出厂日期", .Range("A1:Z1"), 0)
    arr(l, 6) = .Cells(j, colnum)
    l = l + 1
   End If
jx:
    j = j + 1
 Next

 End With
'

  '    关闭源工作簿，并不保存更改
sourceWorkbook.Close SaveChanges:=False

Worksheets("机床数据").Select
 ActiveSheet.Cells(tcount, 1).Offset(1, 0).Resize(k, 6) = arr

后发现源表数据会被动，因此改成字典遍历的方法

'使用字典的方式遍历，就不用在意顺序
Sub GetData()
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim myrange As Range
    Dim sheetName As String, path As String
    Dim ws As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim scount As Long, tcount As Long, srow As Long, newcount As Long, startcount As Long
    Dim slastrow As Variant, tlastrow As Variant, colnum As Variant
    Dim rng As Range, rngnew As Variant
    Dim arr, brr, crr

'

    Worksheets("机床数据").Select

    
    tcount = ActiveSheet.Range("A1").End(xlDown).Row '目标表最大行数
    tlastrow = ActiveSheet.Range("A" & tcount).Value '目标表最大行A列的值
    
    '设置目标工作簿、工作表、范围
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = ActiveSheet
    Set targetRange = ActiveSheet.Range("A" & tcount + 1)


    '解除保护
    Range("A:I").Select
    ActiveSheet.Unprotect Password:="chr"

   path = "\\192.168.100.5\生产中心\生产保障部"
   
   f = Dir(path & "\11#生产任务目录.xlsx")
    If f = "" Then
        MsgBox "源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(path & "\" & f, Password:="chr", ReadOnly:=True)
    End If

    Set sourceWorksheet = sourceWorkbook.Worksheets("4发运")
    
'    如果源工作表有过滤，则显示所有数据
    If sourceWorksheet.FilterMode = True Then
     sourceWorksheet.ShowAllData
    End If
    '源数据最大行数及最大行序号值
    scount = sourceWorksheet.Range("A1").End(xlDown).Row
    slastrow = sourceWorksheet.Range("A" & scount).Value
    
    
    
    If scount - 825 + 1 = tcount Then '要2020年起的数据
    
     '    关闭源工作簿，并不保存更改
          sourceWorkbook.Close SaveChanges:=False
        
    '          ActiveSheet.Protect Password:="chr" '
        
          MsgBox "没有新增数据"
          
     Else
    
    
    
    Set tarr = targetWorksheet.Range("A1:F" & tcount) '目标表范围
    Set sarr = sourceWorksheet.Range("A826:Z" & scount) '源表范围,要2020年起的数据，这里就不进行查找了
    
    Set dic = CreateObject("scripting.dictionary") '建字典
    
    For i = 2 To tcount
      dic(tarr.Cells(i, 1).Value) = tarr.Cells(i, 1).Value  '将目标表第一列装入字典。固定格式取值，字典的Item值赋空值（因为这里不需要做任何一一对应的处理）
    Next
    
    ReDim arr(1 To scount, 1 To 6) '定义一个过渡区域ARR，使其行列数与源表一致
    
    k = 1
    For j = 2 To scount
       If Not dic.exists(sarr.Cells(j, 1).Value) Then  '字典中的值与源表中第一列的值对比，如果对不上就取下面相应的值赋到相应位置
            arr(k, 1) = sarr.Cells(j, 1) '序号
            arr(k, 2) = sarr.Cells(j, 2)  '机床编号
            arr(k, 3) = sarr.Cells(j, 3)  '出厂编号
            arr(k, 4) = sarr.Cells(j, 5)  '机床型号
            arr(k, 5) = sarr.Cells(j, 7)  '客户名称
            arr(k, 6) = sarr.Cells(j, 21)  '发运日期（出厂日期）
    
            k = k + 1
        End If
    Next
    '关闭源文件
    sourceWorkbook.Close SaveChanges:=False
    
    
    '将arr中的内容复制到目标表格去
    
    Worksheets("机床数据").Select
    ActiveSheet.Cells(tcount, 1).Offset(1, 0).Resize(k, 6) = arr
    
    
    
    
    '新增数据加边框
    newcount = ActiveSheet.Range("A1").End(xlDown).Row
    Set myrange = ActiveSheet.Range("A" & tcount + 1 & ":K" & newcount)
    ' 为区域添加边框
    With myrange.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    End With
    
    
    '行高
    Rows(tcount + 1 & ":" & newcount).Select
    Selection.RowHeight = 20

    End If
    
    newcount = ActiveSheet.Range("A1").End(xlDown).Row
        
  '排序
   ActiveSheet.Range("A1:K" & newcount).Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
    
     '保护区域,单元格只读
   
    ActiveSheet.Range("A1:F" & newcount).Locked = True
    ActiveSheet.Protect Password:="chr" '
    '

 
End Sub