Question

我需要复制包含内部 color = 6 （vbyellow）的列的单元格，然后将它们粘贴到新工作表中并将此新叶保存在 txt c：\ code.txt 中的格式。任何人都可以帮我这个吗？

Answer 1

抱歉，第一篇文章。我不确定格式如何在这个网站上运行。您需要测试以下内容。相应地添加错误处理和重构。您还需要在工作表的某处定义范围columnRng，实际上您可能将其更改为inputRange，因为它不必是列。作为一个侧面声明，保存值由某种颜色突出显示给我听起来有点像一堆蠕虫，但你比我更了解你的问题域。

Option Explicit


Sub SaveValues()

Const colorLongVal As Long = 6
Dim rng As Range
Dim wks As Worksheet
Dim varToWriteToSht As Variant
Dim txtFileFullPath As String

txtFileFullPath = "f:\test.txt"
Set rng = Range("columnRng")
varToWriteToSht = GetValsByColour(rng, colorLongVal)

Set wks = WriteValsToNewSht(varToWriteToSht)
SaveWorkSheetAsTxtFile wks, txtFileFullPath

End Sub

Sub SaveWorkSheetAsTxtFile(ws As Worksheet, txtFileFullPath As String)

ws.SaveAs txtFileFullPath, xlTextMSDOS

End Sub


'Accepts 2D variant array. Creates a new worksheet and writes to the top right hand corner of that sheet

Public Function WriteValsToNewSht(varToWriteToSht As Variant) As Worksheet

Dim wks As Worksheet
Dim resultRowsCnt As Long
Dim resultColsCnt As Long
Dim rngToWriteTo As Range

Set wks = ThisWorkbook.Worksheets.Add()
resultRowsCnt = UBound(varToWriteToSht, 1)
resultColsCnt = UBound(varToWriteToSht, 2)

If resultRowsCnt = 0 Then resultRowsCnt = 1
If resultColsCnt = 0 Then resultColsCnt = 1
Set rngToWriteTo = wks.Range("A1").Resize(resultRowsCnt, resultColsCnt)
rngToWriteTo.Value = varToWriteToSht

Set WriteValsToNewSht = wks

End Function

'Returns a variant array of the values that is writable directly to a range
Function GetValsByColour(rng As Range, interiorColourVal As Long) As Variant

Dim resultVar As Variant
Dim resultCol As Collection
Dim i As Long
Dim j As Long

Dim val As Variant
Dim cell As Range

Set resultCol = New Collection

'You might want to not use a collection and redim the result array yourself
For Each cell In rng
    If cell.Interior.ColorIndex = interiorColourVal Then
        resultCol.Add cell.Value
    End If
Next cell

ReDim resultVar(1 To resultCol.Count, 1 To 1)
For i = 1 To resultCol.Count
    resultVar(j + 1, 1) = resultCol.Item(i)
    j = j + 1
Next i

GetValsByColour = resultVar

End Function

Answer 2

我会在细胞中使用过滤器或循环。

即使这还没有完成，它应该让你开始......

  Sub Macro2()
      Columns("A:A").AutoFilter Field:=1, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
      Columns("A:A").Copy
      Workbooks.Add
      Selection.PasteSpecial Paste:=xlPasteValues
      ActiveWorkbook.SaveAs Filename:="C:\Code.txt", FileFormat:=xlTextMSDOS, CreateBackup:=False

  End Sub

仅复制内部索引颜色= 6的单元格

2 个答案: