根據Excel工作表中存在的值檢索列標題

我有兩個工作表（表1和表2）。工作表1有500X500表格。我想 - 遍歷每行（每個細胞） - 確定具有在它的值「X」細胞 - 匹克相應的列標題值並將其存儲在一個小區中工作表2根據Excel工作表中存在的值檢索列標題

例如

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

我曾嘗試循環算法的形式，但似乎並沒有工作的一種方式。任何人都可以請幫助我，因爲我對宏很新。

來源

2013-07-23 Shhhh

試試這個..假設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

來源

2013-07-23 17:26:23 matzone

我已經把價值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中。

來源

2013-07-23 19:38:50

根據Excel工作表中存在的值檢索列標題

回答

相關問題