Question

我有一个电子表格，其中有许多不同的表格，这些表格一直在增长和减少。

会有多张看起来相同但数据不同的表格。

单元格C1包含日期
列A包含记录ID
列B包含百分比

我需要将％保存在记录ID中，并在单独的工作表中创建一个日期为标题的列。

如果日期已经存在，我需要使用不同工作表中的新数据覆盖该列中的数据。所有电子表格中的日期都是一致的。

任何帮助将不胜感激

提前致谢

Answer 1

我希望你不要以为我只是给你所有的代码。你应该从做这样的事情开始。

Dim ids() As Integer
Dim percentages() As String
Dim strDate As Date
Dim sheetName As String

x = Sheets.Count

For i = x To 1 Step -1
    ReDim Preserve ids(i)
    ReDim Preserve percentages(i)

    sheetName = YourSheet & i
    date = sheetName.Range("C1").Value
    ids(i) = sheetName.Range("A" & i).Value
    percentages(i) = sheetName.Range("B" & i).Value
Next i

然后将其全部放入新的工作表中。

Answer 2

这是我最后写的代码来执行我的功能。我正在读取数据的单元格发生了变化，我也在代码中留下了错误。如果有人想就如何改进它发表意见，我会欢迎他们，因为我是新手

Sub SavePercentage()
Dim ids(10000) As Long
Dim Percentages(10000) As String
Dim MEDate As Date
Dim sheetName As String
Dim i As Integer
Dim Sht As Worksheet
Dim n As Integer
Dim c As Integer
Dim r As Integer
Dim DateCol As Long
'Dim DCol As Range
Dim LastCol As Long
Dim lastrow As Range
Dim Percent As Worksheet
Dim v As Variant
Dim FindRange As Range
Dim ra As Range
Dim IDRow As Long
Dim Findcell As Range



x = Sheets.Count
n = 0

For i = 1 To 3
    Set Sht = Sheets(i)

    If Sht.Name <> "Options" And _
        Sht.Name <> "PercentageComplete" And _
        Sht.Visible = xlSheetVisible Then

        'Debug.Print Sht.Name

        MEDate = Sht.Range("C3").Value
        Debug.Print MEDate
        r = 8
        Do While Sht.Cells(r, 6) <> ""
            n = n + 1
            If n > 10000 Then
                MsgBox "Plot Array size exceeded"
                Exit Do
            End If

            ids(n) = Sht.Cells(r, 6)
            Percentages(n) = Sht.Cells(r, 20)
            r = r + 1
            'Debug.Print ids(n), Percentages(n)
        Loop
    End If
Next i

Set Sht = ActiveSheet
Set Percent = Worksheets("percentagecomplete")
Percent.Visible = xlSheetHidden
Percent.Activate
For Each FindRange In [2:2]
    If FindRange.Value = MEDate Then
        DateCol = FindRange.Column
    End If
Next


    If DateCol = 0 Then
            For Each FindRange In [2:2]
                If FindRange.Column > 1 Then
                    If FindRange.Value = 0 Then
                        DateCol = FindRange.Column
                        'Debug.Print DateCol
                        Percent.Cells(2, DateCol).Value = MEDate
                        Exit For
                    End If
                End If
            Next
    End If
Set FindRange = Percent.Range("b2:b10000")

For i = 1 To 10000
    If ids(i) = 0 Then Exit For
    'Debug.Print ids(i)
    'For Each FindRange In ("b1:b10000")
    For Each Findcell In FindRange.Cells
        If Findcell.Value = 0 Then Exit For

                If Findcell.Value = ids(i) Then
                'Debug.Print findcell.Value
                    IDRow = Findcell.Row
                    Exit For
                Else
                    IDRow = 0
                End If

    Next

    If IDRow = 0 Then
        'For Each FindRange In [b:b]
        For Each Findcell In FindRange.Cells
            'If FindRange.Row > 1 Then
                If Findcell.Value = 0 Then
                    IDRow = Findcell.Row
                    'Debug.Print IDRow
                    Percent.Cells(IDRow, 2).Value = ids(i)
                    Exit For
                End If
            'End If
        Next
    End If

    Percent.Cells(IDRow, DateCol).Value = Percentages(i)



Next

Percent.Visible = xlSheetVeryHidden
Sht.Activate

End Sub

循环查找值并将其值保存在另一张纸上

2 个答案: