第一行筛选数据未复制 VBA Excel

huangapple go评论140阅读模式
英文:

First row of Filtered data not copied VBA Excel

问题

以下是代码的翻译部分:

Sub MakeAbsence()

    Dim template As Worksheet
    Dim data As Worksheet
    Dim output As Worksheet
    Dim output_remain As Worksheet
    Dim teacher_list As Worksheet
    
    Set template = ThisWorkbook.Worksheets("Template")
    Set data = ThisWorkbook.Worksheets("Template_Data")
    Set teacher_list = ThisWorkbook.Worksheets("Template_teacher")
    
    ' 获取老师的名字
    Dim teachers_range As Variant
    teachers_range = teacher_list.Range("A2:A5")  ' 有没有自动化这个的想法?
    
    ' 遍历老师
    Dim teacher As Variant
    
    For Each teacher In teachers_range
    
        ' 复制模板
        template.Copy After:=Worksheets(Worksheets.Count)
        Set output = ActiveSheet
        output.Name = teacher
        
        ' 修改名字
        Dim teacher_range As Range
        Set teacher_range = output.Range("A6").EntireRow.Find("[teacher]", LookIn:=xlValues)
        teacher_range.Value = teacher
      
        ' 筛选数据
        data.Range("B1:D" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).AutoFilter Field:=3, Criteria1:=teacher
        
        ' 复制数据
        Dim data_range As Range
        Set data_range = data.Range("B2:C" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        If Not data_range Is Nothing Then
            ' 复制前14行到输出工作表
            If data_range.Rows.Count > 14 Then
                data_range.Resize(14).Offset(1, 0).Copy Destination:=output.Range("B8")
                
                ' 复制剩余的行到新工作表
                Dim remaining_data_range As Range
                Set remaining_data_range = data_range.Resize(data_range.Rows.Count - 14).Offset(15, 0)
                template.Copy After:=Worksheets(Worksheets.Count)
                
                Set output_remain = ActiveSheet
                output_remain.Name = teacher & "_2"
                remaining_data_range.Copy Destination:=ActiveSheet.Range("B8")
                
                Dim teacher_range_remain As Range
                Set teacher_range_remain = output_remain.Range("A6").EntireRow.Find("[teacher]", LookIn:=xlValues)
                teacher_range_remain.Value = teacher
            Else
                data_range.Offset(1, 0).Copy Destination:=output.Range("B8")
            End If
        End If
        
        ' 删除筛选
        data.AutoFilterMode = False
        
    Next teacher
    
End Sub

希望这对你有帮助。如果你有其他问题,请随时提出。

英文:

This is my Virtual Basic Application Code from my excel spreadsheet,(You can download it, scroll down)


Sub MakeAbsence()

    Dim template As Worksheet
    Dim data As Worksheet
    Dim output As Worksheet
    Dim output_remain As Worksheet
    Dim teacher_list As Worksheet
    
    Set template = ThisWorkbook.Worksheets("Template")
    Set data = ThisWorkbook.Worksheets("Template_Data")
    Set teacher_list = ThisWorkbook.Worksheets("Template_teacher")
    
    ' Getting Teacher's Names
    Dim teachers_range As Variant
    teachers_range = teacher_list.Range("A2:A5")  'Any idea how to automate this?
    
    ' Loop Through Teacher
    Dim teacher As Variant
    
    For Each teacher In teachers_range
    
        ' Copy Template
        template.Copy After:=Worksheets(Worksheets.Count)
        Set output = ActiveSheet
        output.Name = teacher
        
        ' Change Name
        Dim teacher_range As Range
        Set teacher_range = output.Range("A6").EntireRow.Find("[teacher]", LookIn:=xlValues)
        teacher_range.Value = teacher
      
        ' Filtering data
        data.Range("B1:D" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).AutoFilter Field:=3, Criteria1:=teacher
        
        ' Copying Data
        Dim data_range As Range
        Set data_range = data.Range("B2:C" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        If Not data_range Is Nothing Then
            ' Copy the first 14 rows to the output worksheet
            If data_range.Rows.Count > 14 Then
                data_range.Resize(14).Offset(1, 0).Copy Destination:=output.Range("B8")
                
                ' Copy the remaining rows to a new worksheet
                Dim remaining_data_range As Range
                Set remaining_data_range = data_range.Resize(data_range.Rows.Count - 14).Offset(15, 0)
                template.Copy After:=Worksheets(Worksheets.Count)
                
                Set output_remain = ActiveSheet
                output_remain.Name = teacher & "_2"
                remaining_data_range.Copy Destination:=ActiveSheet.Range("B8")
                
                  Dim teacher_range_remain As Range
                  Set teacher_range_remain = output_remain.Range("A6").EntireRow.Find("[teacher]", LookIn:=xlValues)
                  teacher_range_remain.Value = teacher
            Else
                data_range.Offset(1, 0).Copy Destination:=output.Range("B8")
            End If
        End If
        
        ' delete filter
        data.AutoFilterMode = False
        
    Next teacher
    
End Sub

Why My first row doesnt get copied as well? And is there any way to automate this code?

' Getting Teacher's Names
Dim teachers_range As Variant
teachers_range = teacher_list.Range("A2:A5") 

This is my data
第一行筛选数据未复制 VBA Excel

第一行筛选数据未复制 VBA Excel
So anyone know where did Abigail Taylor went?
>! Toilet maybe? :/
第一行筛选数据未复制 VBA Excel

Here is the GDrive Link for the EXCEL FILES

答案1

得分: 1

1 可配置/动态教师列表

一种快速而简单的解决方案是查找工作表中的最后一行,然后执行 Range("A2:A" & lastRow)

你已经在这里执行了类似的操作:

       ' 过滤数据
        data.Range("B1:D" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).AutoFilter Field:=3, Criteria1:=teacher

你只需要对相同的思路进行适当的调整:

    teachers_range = teacher_list.Range("A2:A" & teacher_list.Cells(teacher_list.Rows.Count, "A").End(xlUp).Row)  ' 有自动化这一步的想法吗?

替代方法

个人而言,每当我处理事物列表(即"配置")时,我总是使用Excel表格,因为我发现它们比简单的电子表格范围更容易使用,因为你可以直观地看到表格内部和外部的内容。创建表格之后(选择范围,插入表格),你可以使用 ThisWorkbook.Worksheets("工作表名称").ListObjects("表格名称") 来访问它们。

2 缺失的行

最简单的解决方案是,不要从第2行开始(然后稍后进行偏移),而是从第3行开始。

        Set data_range = data.Range("B3:C" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible)

' ... 不要偏移
                data_range.Resize(14).Copy Destination:=output.Range("B8")

' ... 不要偏移
                data_range.Copy Destination:=output.Range("B8")

为什么呢?

data_range 实际上是一个范围的集合,注意它包括了 B2:C2 和 B14:C23;当你进行偏移时,它变成了 B3:C3 和 B15:C24。

?data_range.Address
$B$2:$C$2,$B$14:$C$23
?data_range.Offset(1,0).Address
$B$3:$C$3,$B$15:$C$24

你之所以使用 offset 是为了尝试去除 B2:C2,但实际上它并没有这样做,它只是将 B2:C2 变成了 B3:C3(B3:C3 被筛选掉,所以它不会被复制)。B14:C23 需要保持原样,但它被更改为 B15:C24(B24:C24 被筛选掉,所以它不会被复制);最终你实际上只复制了 B15:C23,这不是你想要的。

英文:

1 Configurable / dynamic teacher list

The quick and dirty solution is to find the last row in that worksheet, and do Range("A2:A" & lastRow).

You already do this here:

       ' Filtering data
        data.Range("B1:D" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).AutoFilter Field:=3, Criteria1:=teacher

You just need to adapt that same idea:

    teachers_range = teacher_list.Range("A2:A" & teacher_list.Cells(teacher_list.Rows.Count, "A").End(xlUp).Row)  'Any idea how to automate this?

Alternative

Personally, whenever I deal with a list of things (i.e. "configuration") I always use an Excel Table, as I find them easier to work with than simple spreadsheet ranges, because you can see visually what's inside the table and what's outside the table. After you've created the table (select range, Insert Table) you can access them using ThisWorkbook.Worksheets("WorksheetName").ListObjects("TableName").

2 Missing row

The simplest solution is instead of starting from row 2 (and then offsetting later), you simply start from row 3.

        Set data_range = data.Range("B3:C" & data.Cells(data.Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible)

' ... don't offset
                data_range.Resize(14).Copy Destination:=output.Range("B8")

' ... don't offset
                data_range.Copy Destination:=output.Range("B8")

Why?

data_range is actually a collection of ranges, notice that there's a B2:C2 and a B14:C23; when you offset it, it becomes B3:C3 and B15:C24.

?data_range.Address
$B$2:$C$2,$B$14:$C$23
?data_range.Offset(1,0).Address
$B$3:$C$3,$B$15:$C$24

You're using offset to try to remove B2:C2 but it's actually not doing that, it's just changing the B2:C2 to B3:C3 (B3:C3 is filtered out so it doesn't get copied). B14:C23 needs to stay as it is, but it's being changed to B15:C24 (B24:C24 is filtered out so it doesn't get copied); what you end up with is actually just B15:C23 being copied, which is not what you want.

huangapple
  • 本文由 发表于 2023年3月7日 12:37:10
  • 转载请务必保留本文链接:https://go.coder-hub.com/75658092.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定