根据单元格值复制数据

Question

我有点卡住了，希望能找到一些帮助。我在 VBA 方面有一些经验，但这个特殊问题超出了我的编程知识。

我有一张包含 1000 - 1250 行数据和 20 - 60 列的数据表，可以每月更改。

我希望做的是查看每个单元格中的 X，当找到它时，它将在单独的选项卡上创建一个新行。该行将包含找到 X 的行中的第一个单元格以及找到 X 的列的列标题。

我已经能够编写一些可以在工作表中找到 X、在另一页上创建新项目等的东西，但是我无法让一个脚本来完成我需要的所有事情。

这是数据结构的一个例子：

Data

预期结果：

Output

抱歉链接，我太新，无法发布照片。

任何有关如何实现此目的的帮助、文档、提示或类似内容都将非常有帮助且非常感谢。感谢您的关注！

安德鲁

编辑：

我整理的一些代码：

Dim uSht As String
Dim wsExists As Boolean
Dim lRow As Long
Dim lcol As Long
Dim ws As Worksheet



Sub CopyData()

'Setup Sheetnames
uSht = "UPLOAD"
uTem = "TEMPLATE"

' Stop flicker
Application.ScreenUpdating = False

' Check for Upload Worksheet
WorksheetExists (uSht)

'MsgBox (wsExists)
If wsExists = False Then
' If it does not exist, create it
Call CreateSheet("UPLOAD")
End If

'Setup stuff
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets(uTem)
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(uSht)

lRow = Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xlToLeft).Column

'MsgBox (lRow)
'MsgBox (lCol)

Range(Cells(lRow, lColumn)).Select


Application.ScreenUpdating = True

End Sub

Sub CreateSheet(wsName)
'Creates the uSht worksheet
With ThisWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = uSht
End With
End Sub

Function WorksheetExists(wsName As String) As Boolean
'Check to see if uSht exists and return.
wsName = UCase(wsName)
For Each ws In ThisWorkbook.Sheets
    If UCase(ws.Name) = wsName Then
        wsExists = True
        Exit For
    End If
Next
WorksheetExists = wsExists
End Function

Answer 1

您需要一个 Find/FindNext 循环来定位第一个工作表中的所有 X 值。找到找到的单元格后，可以通过单元格的行和列来识别位置和项目。

Option Explicit

Sub Macro1()
    Dim addr As String, loc As String, pro As String
    Dim ws2 As Worksheet, fnd As Range

    Set ws2 = Worksheets("sheet2")

    With Worksheets("sheet1")
        Set fnd = .Cells.Find(What:="x", after:=.Cells(1, 1), _
                              LookIn:=xlFormulas, LookAt:=xlWhole, _
                              SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                              MatchCase:=False, SearchFormat:=False)
        If Not fnd Is Nothing Then
            addr = fnd.Address(0, 0)
            Do
                loc = .Cells(fnd.Row, "A").Value
                pro = .Cells(1, fnd.Column).Value
                With ws2
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = loc
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 1) = pro
                End With
                Set fnd = .Cells.FindNext(after:=fnd)
            Loop Until addr = fnd.Address(0, 0)
        End If
    End With

End Sub

Answer 2

从这里使用FindAll：Extracting specific cells from multiple Excel files and compile it into one Excel file （但将LookAt:=xlPart改为LookAt:=xlWhole）

粗略的轮廓：

Dim col, c, dest As Range

Set dest = sheets("results").Range("A2")
Set col = FindAll(sheets("data").range("a1").currentregion, "X")

For each c in col
    dest.resize(1,2).value = array(c.entirerow.cells(1).value, _
                                   c.entirecolumn.cells(1).value)
    set dest = dest.offset(1, 0)
next