excel - 如何通过 VBA 为数据设置 ID

Question

在工作表的图片中，我从“Ark2”获取数据，在工作表中，我将数据获取到“Ark1”。在 Ark1 中，我想为数据提供一个 ID。我展示了一个黄色、灰色、绿色和蓝色的例子。我希望文本 ID 与示例行“K”中的一样。

代码在最后添加..

    Sub MyProcedure()
a = Worksheets("ark1").Cells(Rows.Count, 1).End(xlUp).Row

MsgBox (a)

End Sub

Private Sub CommandButton1_Click()
Dim nøgletal As String, år As Integer
    Worksheets("Ark2").Select
    nøgletal = Range("B2")
    år = Range("C2")
    Worksheets("Ark1").Select
    Worksheets("Ark1").Range("A4").Select
    ThisWorkbook.Worksheets("Ark1").Range("A1:A100").Value = ThisWorkbook.Worksheets("Ark2").Range("A12:A100").Value
    ThisWorkbook.Worksheets("Ark1").Range("B1:B100").Value = ThisWorkbook.Worksheets("Ark2").Range("B12:B100").Value
   ThisWorkbook.Worksheets("Ark1").Range("C1:C100").Value = ThisWorkbook.Worksheets("Ark2").Range("C12:C100").Value
    ThisWorkbook.Worksheets("Ark1").Range("E1:E100").Value = ThisWorkbook.Worksheets("Ark2").Range("E12:E100").Value
   ThisWorkbook.Worksheets("Ark1").Range("G1:G100").Value = ThisWorkbook.Worksheets("Ark2").Range("M12:M100").Value
   ThisWorkbook.Worksheets("Ark1").Range("F1:F100").Value = ThisWorkbook.Worksheets("Ark2").Range("N12:N100").Value
   ThisWorkbook.Worksheets("Ark1").Range("H1:H100").Value = ThisWorkbook.Worksheets("Ark2").Range("O12:O100").Value
    If Worksheets("Ark1").Range("A4").Offset(1, 0) <> "" Then
    Worksheets("Ark1").Range("A4").End(xlDown).Select
    End If
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Value = nøgletal
    ActiveCell.Offset(0, 1).Select
    ActiveCell.Value = år
    Worksheets("Ark2").Select
    Worksheets("Ark2").Range("B2", "B16").Select
End Sub


    Sub x()

Dim lngDataColumns As Long
Dim lngDataRows As Long

lngDataColumns = 3
lngDataRows = 15


For t = 1 To lngDataRows

Range("l2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
        Application.Transpose(Range("f1:h1").Value)

Range("M2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
        Application.Transpose(Range("f1:h1").Offset(t).Value)

Next t

End Sub

标签： excelvba

Answer 1

一个特殊的移调卷。2

调整常量部分中的值以满足您的需要。

Range1 ( ) 中的第一个数据行A2:C2必须有值。

编码

Sub TransposeAH()

    Const cSheet1 As Variant = "Ark1"   ' Sheet1 Name/Index
    Const cSheet2 As Variant = "Ark1"   ' Sheet2 Name/Index
    Const cFirst As Integer = 2         ' First Row Number
    Const cCol1First As Variant = "A"   ' Range1 First Column Letter/Number
    Const cCol1Last As Variant = "C"    ' Range1 Last Column Letter/Number
    Const cCol2First As Variant = "F"   ' Range2 First Column Letter/Number
    Const cCol2Last As Variant = "H"    ' Range2 Last Column Letter/Number
    Const cColumns As Integer = 2       ' Number of New Columns
    Const cFirstCell As String = "L1"   ' Target Range First Cell Address

    Dim vntH As Variant  ' Range2 Headers
    Dim vnt2 As Variant  ' Range2 Array
    Dim vnt3 As Variant  ' Range1 Temp Array (if value is "")
    Dim vnt1 As Variant  ' Range1 Array
    Dim vntT As Variant  ' Target Array
    Dim LastUR As Long   ' Last Used Row
    Dim i As Long        ' Arrays Row Counter
    Dim j As Integer     ' Arrays Column Counter
    Dim k As Long        ' Target Array Rows Counter
    Dim m As Integer     ' Range1 Temp Array Column Counter

    ' From Sheet1 to Arrays.
    With Worksheets(cSheet1)
        ' Calculate Last Used Row.
        With .Range(.Cells(cFirst, cCol1First), .Cells(.Rows.Count, cCol2Last))
            If .Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
                Is Nothing Then Exit Sub
            LastUR = .Find("*", , , , , 2).Row
        End With
        ' Paste ranges into arrays.
        vnt1 = .Range(.Cells(cFirst, cCol1First), .Cells(LastUR, cCol1Last))
        vnt2 = .Range(.Cells(cFirst, cCol2First), .Cells(LastUR, cCol2Last))
        vntH = .Range(.Cells(cFirst - 1, cCol2First), _
                .Cells(cFirst - 1, cCol2Last))
    End With

    ' Resize Target Array.
    ReDim vntT(1 To UBound(vnt2) * UBound(vnt2, 2), _
            1 To cColumns + UBound(vnt1, 2))

    ' Write Range2 Array to Target Array.
    For i = 1 To UBound(vnt2)
        For j = 1 To UBound(vnt2, 2)
            k = k + 1
            vntT(k, 1) = vntH(1, j)
            vntT(k, 2) = vnt2(i, j)
        Next
    Next

    ' Resize Range1 Temp Array (if value is "")
    ReDim vnt3(1 To 1, 1 To UBound(vnt1, 2))
    ' Copy first line of Range1 Array to Range1 Temp Array.
    For m = 1 To UBound(vnt3, 2)
        vnt3(1, m) = vnt1(1, m)
    Next

    ' Write Range1 Array to Target Array.
    k = 0
    For i = 1 To UBound(vnt1)
        For j = 1 To UBound(vnt1, 2)
            k = k + 1
            For m = 1 To UBound(vnt2, 2)
                If vnt1(i, m) <> "" Then
                    If vnt1(i, m) <> vnt3(1, m) Then
                        vnt3(1, m) = vnt1(i, m)
                    End If
                End If
                vntT(k, m + cColumns) = vnt3(1, m)
            Next
        Next
    Next

    ' Paste Target Array into Target Range resized
    ' from Target Range First Cell Address.
    With Worksheets(cSheet2).Range(cFirstCell)
        .Resize(UBound(vntT), UBound(vntT, 2)) = vntT
    End With

End Sub