如何使用宏将文件中合格不合格的焊口分开，台帐中焊口已用颜色区分

603001932

如何使用宏在生成的文件中将合格不合格的焊口分开填写，台帐不变，台帐中焊口合格与否已用颜色区分。

vbee

寥寥数语，不知所云

603001932

vbee 发表于 2018-8-6 19:07
寥寥数语，不知所云

能不能将数据里只筛选出黑色字体的E列填到Sheet1的K列

vbee

委托编号，如果是唯一的，VLOOKUP就行

vbee

合格焊口，你自己填的有1个，也有2个，也有3个，用逗号分隔，不理解

603001932

vbee 发表于 2018-8-7 08:44
合格焊口，你自己填的有1个，也有2个，也有3个，用逗号分隔，不理解

数据是按委托分的，因为同一委托有很多焊口，有合格的也有不合格的，在sheet1里分开，标为红色的为不合格

一把小刀闯天下

603001932 发表于 2018-8-7 08:57
数据是按委托分的，因为同一委托有很多焊口，有合格的也有不合格的，在sheet1里分开，标为红色的为不合格

Option Explicit

Sub test()
  Dim arr, i, dic, t As String
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("数据")
    For i = 3 To .Cells(Rows.Count, "c").End(xlUp).Row
      If .Cells(i, "l") = "合格" Then   '不合格的不作统计
        t = .Cells(i, "c").Value
        If dic.exists(t) Then
          dic(t) = dic(t) & "," & .Cells(i, "e")
        Else
          dic(t) = "," & .Cells(i, "e")
        End If
      End If
    Next
  End With
  With Sheets("sheet1")
    .[k:k].ClearContents
    For i = 3 To .Cells(Rows.Count, "c").End(xlUp).Row
      t = .Cells(i, "c")
      If dic.exists(t) Then .Cells(i, "k") = CStr(dic(t))
    Next
  End With
End Sub

603001932

一把小刀闯天下 发表于 2018-8-7 10:00
Option Explicit

Sub test()

Private Sub CommandButton1_Click()
Dim N%, K%, i%
With Sheets("Sheet1")
   .UsedRange.Offset(2).Delete
For i = 3 To [N65536].End(3).Row
      If Range("C" & i) <> nw Then
         N = N + 1: K = 13
         .Range("1:2").Copy .Range("A" & N * 2 + 1)
         .Range("A" & N * 2 + 2) = Range("A" & i)
         .Range("B" & N * 2 + 2) = Range("B" & i)
         .Range("C" & N * 2 + 2) = Range("C" & i)
         .Range("D" & N * 2 + 2) = Range("D" & i)
         .Range("E" & N * 2 + 2) = Range("G" & i)
         .Range("F" & N * 2 + 2) = Range("H" & i)
         .Range("G" & N * 2 + 2) = Range("I" & i)
         .Range("H" & N * 2 + 2) = Range("J" & i)
         nw = Range("C" & i)
      End If
      If Trim(Range("E" & i)) <> "" And Range("E").Interior.Color = 255 Then .Range("K" & N * 2 + 2) = .Range("K" & N * 2 + 2) & "," & Range("E" & i)
      K = K + 1
      If Trim(Range("E" & i)) <> "" And Range("E").Interior.Color = 0 Then .Range("L" & N * 2 + 2) = .Range("L" & N * 2 + 2) & "," & Range("E" & i)
      K = K + 1
   Next
   .Activate
End With
End Sub
这个执行不了

一把小刀闯天下

603001932 发表于 2018-8-7 10:56
Private Sub CommandButton1_Click()
Dim N%, K%, i%
With Sheets("Sheet1")

'我不太可能用你的方法来解决你的问题，修改你的代码还不如重写

'7楼的代码稍作修改，使用颜色判断是否需要处理，自己修改

Option Explicit

Sub test()
  Dim arr, i, dic, t As String
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("数据")
    For i = 3 To .Cells(Rows.Count, "c").End(xlUp).Row
      If .Cells(i, "l").Font.Color <> vbRed Then '字体红色不作处理
        t = .Cells(i, "c").Value
        If dic.exists(t) Then
          dic(t) = dic(t) & "," & .Cells(i, "e")
        Else
          dic(t) = "," & .Cells(i, "e")
        End If
      End If
    Next
  End With
  With Sheets("sheet1")
    .[k:k].ClearContents
    For i = 3 To .Cells(Rows.Count, "c").End(xlUp).Row
      t = .Cells(i, "c")
      If dic.exists(t) Then .Cells(i, "k") = CStr(dic(t))
    Next
  End With
End Sub