判断插入行数

胡光

如何通过vba批量对第一个单元格的行数来判断，进行单元格底部插入相应的行数使本单元格总行数为8行。

Jaofuan

没有附件，也不知道根据什么判断

胡光

上传附件：

cpp755625083

上传附件，原图，效果图

胡光

上传附件：

sleeping_dogs

描述不清楚，别人一般难帮你。你可能不方便告诉大家你做这件事的目的，所以别人可能因此不懂如何帮你解决。你附件的举例还是让人有点困惑得，你在举例的时候应该放上插入前和插入后的对比，不然很难理解你这个附件的举例。不知道我理解错没有，我理解就是把每个A列的“对象”扩充成8行，看附件。

胡光

sleeping_dogs 发表于 2019-6-7 19:25
描述不清楚，别人一般难帮你。你可能不方便告诉大家你做这件事的目的，所以别人可能因此不懂如何帮你解决。 ...

就是像你框出来的的那样
那个根据公式或者代码自动判断插入行

sleeping_dogs

Sub insert_copy()
  Dim rg As Range
  Dim tg As Range
  Set tg = ActiveSheet.Range("a:a").SpecialCells(xlCellTypeConstants, 23)


  Dim dic As Object
  Set dic = CreateObject("scripting.dictionary")

  For Each rg In tg                      '确定每个需要插入的单元格,并记录下来，避免插入后发生位置变动
   
    If rg.MergeArea.Row = rg.Row Then
         i = i + 1
         dic.Add i, rg.MergeArea
    End If
  Next
   
  For Key = 1 To dic.Count
     Dim tp As Integer
     
     With dic(Key)
     rg_count = .Count
     
     If rg_count < 8 Then
       first = rg_count
     Do Until rg_count = 8
        If rg_count = first Then
        .Rows(rg_count).EntireRow.Copy
        .Rows(rg_count).EntireRow.Insert Shift:=xlDown
        .Rows(rg_count + 1).Offset(, 4).Resize(1, 4).ClearContents
        Else: .Rows(rg_count).EntireRow.Insert
        End If
        rg_count = rg_count + 1
      Loop
     End If
     End With
     
    Next
   
   
End Sub

sleeping_dogs

Sub insert_copy()
  Dim rg As Range
  Dim tg As Range
  Set tg = ActiveSheet.Range("a:a").SpecialCells(xlCellTypeConstants, 23)


  Dim dic As Object
  Set dic = CreateObject("scripting.dictionary")

  For Each rg In tg                      '确定每个需要插入的单元格,并记录下来，避免插入后发生位置变动
   
    If rg.MergeArea.Row = rg.Row Then
         i = i + 1
         dic.Add i, rg.MergeArea
    End If
  Next
   
  For Key = 1 To dic.Count
     Dim tp As Integer
     
     With dic(Key)
     rg_count = .Count
     
     If rg_count < 8 Then
       first = rg_count
     Do Until rg_count = 8
        If rg_count = first Then
        .Rows(rg_count).EntireRow.Copy
        .Rows(rg_count).EntireRow.Insert Shift:=xlDown
        .Rows(rg_count + 1).Offset(, 4).Resize(1, 4).ClearContents
        Else: .Rows(rg_count).EntireRow.Insert
        End If
        rg_count = rg_count + 1
      Loop
     End If
     End With
     
    Next
   
   
End Sub

sleeping_dogs

胡光 发表于 2019-6-10 00:50
就是像你框出来的的那样
那个根据公式或者代码自动判断插入行

好像不能直接发代码，发了几次都失败了。我复制代码到附件里面，打开复制就可以了。