Question

我有两张工作表（第1页和第2页）。表1有500X500表。我想要 - 遍历每一行（每个单元格） - 识别其中具有值“X”的单元格 - 选择相应的列标题值并将其存储在工作表2的单元格中

例如

AA  BB  CC  DD  EE  FF  GG  HH
GHS                     X   
FSJ         X               
FSA X                       
MSD                         
SKD                         
SFJ X                       X
SFJ                         
SFM             X           
MSF                     X

有没有办法编写一个以

形式提取值的宏

GHS -> GG
FSJ->DD
.
.
SFJ->BB HH

我尝试过循环算法，但似乎没有用。任何人都可以帮助我，因为我对宏很新。

Answer 1

试试这个......假设GHS，FSJ ......在A栏中

Sub ColnItem()
Dim x, y, z As Integer
Dim sItem, sCol As String
Dim r As Range

z = 1
For y = 1 To 500
  sItem = Cells(y, 1)
  sCol = ""
  For x = 2 To 500
    If UCase(Cells(y, x)) = "X" Then
      If Len(sCol) > 0 Then sCol = sCol & " "
      sCol = sCol & ColumnName(x)
    End If
  Next
  If Len(sCol) > 0 Then
    Sheets("Sheet2").Cells(z, 1) = sItem & " -> " & sCol
    z = z + 1
  End If
Next
End Sub

Function ColumnName(ByVal nCol As Single) As String
Dim sC As String
Dim nC, nRest, nDivRes As Integer

sC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nC = Len(sC)

nRest = nCol Mod nC
nDivRes = (nCol - nRest) / nC

If nDivRes > 0 Then ColumnName = Mid(sC, nDivRes, 1)
ColumnName = ColumnName & Mid(sC, nRest, 1)
End Function

Answer 2

我已将值GG等放在Sheet2的不同列中，但可以修改代码以将所有信息（对于一行）放在单个单元格中。

Sub GetColumnHeadings()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range, rng As Range
    Dim off As Integer

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    Set rng1 = ws1.Range("A1").CurrentRegion
    'CurrentRegion is the Range highlighted when we press Ctrl-A from A1
    Set rng2 = ws2.Range("A1")
    Application.ScreenUpdating = False
    For Each rng In rng1
        If rng.Column = 1 Then off = 0
        If rng.Value = "X" Then
            rng2.Value = rng.EntireRow.Cells(1, 1).Value
            off = off + 1
            rng2.Offset(0, off).Value = rng.EntireColumn.Cells(1, 1).Value
        End If
        'if we are looking at the last column of the Sheet1 data, and
        'we have put something into the current row of Sheet2, move to 
        'the next row down (in Sheet2)
        If rng.Column = rng1.Column And rng2.Value <> "" Then
            Set rng2 = rng2.Offset(1, 0)
        End If
    Next rng

    Application.ScreenUpdating = True
    Set rng = Nothing
    Set rng2 = Nothing
    Set rng1 = Nothing
    Set ws2 = Nothing
    Set ws1 = Nothing
End Sub

我还基于原始帖子中的电子表格样本，其中AA似乎位于单元格A1中。

根据excel工作表中存在的值检索列标题

2 个答案: