|
建議特定文字要考慮清楚些, 不然效果會差。- <div><div>Sub zz()</div><div>Dim a, b(), p$, f$, c As New Collection, n&</div><div>a = Range("a1:a" & [a1048576].End(3).Row)</div><div>ReDim b(1 To UBound(a))</div><div>For i = 1 To UBound(a)</div><div> b(i) = a(i, 1)</div><div>Next</div><div>With Application.FileDialog(msoFileDialogFolderPicker)</div><div> .InitialFileName = ThisWorkbook.Path</div><div> .Show</div><div> If .SelectedItems.Count Then p = .SelectedItems(1) Else Exit Sub</div><div>End With</div><div>Application.ScreenUpdating = 0</div><div>f = Dir(p & "" & "*.xls*")</div><div>Do While f <> ThisWorkbook.Name And f <> ""</div><div> Set wb = GetObject(p & "" & f)</div><div> a = wb.Sheets(1).UsedRange</div><div> wb.Close 0</div><div> For i = 1 To UBound(a)</div><div> For j = 2 To UBound(a, 2)</div><div> a(i, 1) = a(i, 1) & "|" & a(i, j)</div><div> Next</div><div> For j = 1 To UBound(b)</div><div> If InStr(a(i, 1), b(j)) > 0 Then</div><div> c.Add f & "|" & a(i, 1)</div><div> Exit For</div><div> End If</div><div> Next</div><div> Next</div><div> f = Dir</div><div>Loop</div><div>If c.Count = 0 Then Application.ScreenUpdating = 1: Exit Sub</div><div>Sheets(2).Activate</div><div>Sheets(2).UsedRange.Clear</div><div>ReDim b(1 To c.Count, 1 To 1000)</div><div>For i = 1 To c.Count</div><div> a = Split(c(i), "|")</div><div> For j = 0 To UBound(a)</div><div> b(i, j + 1) = a(j)</div><div> Next</div><div> n = IIf(j > n, j, n)</div><div>Next</div><div>[a1].Resize(i - 1, n) = b</div><div>Application.ScreenUpdating = 1</div><div>End Sub</div></div><div></div>
复制代码
|
|