Question

我正在构建一个宏，以将原始数据库重组为新的结构化数据库。

它将在原始数据表中查找特定的度量（值，数量等），然后检查它们是否存在于“新数据”表中。

如果存在，则会将数据从原始数据提取到新数据中。

“原始数据”表：

例如，我要实现一个从顶部单元格开始的代码，直到找到“ Value”之类的度量，然后在“ New Data”表中检查该代码是否存在。如果是的话，它将粘贴第一个原始数据中的“值”下面的数据。否则，它会创建一个带有标题“值”的新列。

“新数据”表：

这是我的代码：

Sub test()

    Dim datash As Worksheet
    Dim datarng As Range
    Dim tsh As Worksheet
    Dim startrng As Range
    Dim endrng As Range
    Dim copyrng As Range
    Dim r2 As Range

    'Set tsh = Sheets.Add
    'ActiveSheet.Name = "Data"

    Set datash = ActiveSheet
    Set datarng = datash.Cells(6, 2)
    Set startrng = datarng

    Do Until datarng = ""
       Set datarng = datarng.Offset(1, 0)
    Loop

    Set endrng = datarng(0, 1)    
    Set copyrng = datash.Range(startrng, endrng)

    Dim rng2 As Range

    Set rng2 = datash.Cells(5, 3)

    Dim measurestr As String
    Dim periodstr As String

    Do Until rng2 = ""
        measurestr = rng2(0, 1).Value
        periodstr = rng2.Value
        datash.Range(datash.Cells(startrng.Row, rng2.Column), datash.Cells(endrng.Row, rng2.Column)).Copy

        Set rng2 = rng2.Offset(0, 1)

        ' look for measures in the Data sheet
        Set r2 = ThisWorkbook.Worksheets("Data").Cells(1, findcol(ThisWorkbook.Worksheets("DEMO FOOD+OIL"), "VALUE (€)"))

        Do Until r2 = measuresrt.Value Or r2 = ""
            Set r2 = r2.Offset(0, 1)
        Loop

        'copyrng.Copy Sheets("Data").Range("A1")

        Stop



End Sub

Answer 1

一个快速的模型，不太适合您：

dim i as long, arr as variant, findstr as string, strcols as long, strcold as long
arr = array("Measure","Value") 'etc., you get the idea
for i = lbound(arr) to ubound(arr) step 1
    findstr = arr(i).value
    with sheets("raw data")
        strcols = .Columns(1).Find(What:=findstr, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    end with
    with sheets("new data")
        if strcols > 0 then strcold = .Columns(1).Find(What:=findstr, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    end with
    sheets("new data").columns(strcold).value = sheets("raw data").columns(strcols).value
next i

strcols =字符串列的源，strcold =字符串列的目标...让您同时搜索，找到列号，然后找到value = value。

编辑1：

更新为使用工作表的第一列（“新数据”）

dim i as long, lc as long, findstr as string, strcols as long
lc = sheets("new data").cells(1,sheets("new data").columns.count).end(xltoleft).column
for i = 1 to lc step 1
    findstr = sheets("new data").cells(1,i).value
    with sheets("raw data")
        strcols = .Columns(1).Find(What:=findstr, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
        if strcols > 0 then sheets("new data").columns(i).value = .columns(strcols).value
    end with
next i

如何检查其他工作表中是否存在特定的列名。如果没有，创建它吗？

1 个答案: