Question

EXCEL 表格中，第一列为文本，第二列为数据，怎么用VB编程

原始的数据表如上：
第二列中的单元格为空，对应的第一列删除，在复制第一列到第二个sheet第一列，对应数据也复制过去，做成如下表：





Answer 1

Sub transmit()

Dim i, ar1(), ar2(), ar3(), j, k

ReDim ar1(1 To 100), ar2(1 To 100), ar3(1 To 100)

For j = 2 To 5

    i = 2

    Do

        If Cells(i, j) <> "" Then

            k = k + 1

            If k >= UBound(ar1) Then

                ReDim Preserve ar1(1 To k + 100)

                ReDim Preserve ar2(1 To k + 100)

                ReDim Preserve ar3(1 To k + 100)

            End If

            ar1(k) = Cells(i, 1)

            ar2(k) = Cells(i, j)

            ar3(k) = Cells(1, j)

        End If

        i = i + 1

    Loop Until Cells(i, 1) = ""

Next j

Sheets(Sheets.Count).Range("A2").Resize(k, 1) = WorksheetFunction.Transpose(ar1)

Sheets(Sheets.Count).Range("B2").Resize(k, 1) = WorksheetFunction.Transpose(ar2)

Sheets(Sheets.Count).Range("C2").Resize(k, 1) = WorksheetFunction.Transpose(ar3)

End Sub

 

测试通过，结果会显示在最后一张sheet中，你可以新建一个sheet放在最后来存放结果。

Answer 2

你给出的示意图与描述相矛盾啊。

描述中说，第二列单元格为空，复制。但是PN为D的第二列单元格有值4，你却到它复制过去了。EF也是这种情况。
另外，原sheet中的第二列单元格为空时，第一列删除，其它的列不需要删除吗？

追问

复制 到对应的新表中， PN列还是PN列，数值，放到QTY列，时间放到 date，能后去除筛选，在第三列，做一样的动作，以此类推

每次把黄色的复制下到新表

追答

Option Explicit
Sub ExportToOther()
Dim cols%, rws%, cx%, dx%, strCol$
Dim cols2%, rws2%

Application.ScreenUpdating = False

Sheets(1).Select

With Sheets(1).UsedRange
cols = .Columns.Count
rws = .Rows.Count
End With
With Sheets(2).UsedRange
cols2 = .Columns.Count
rws2 = .Rows.Count
End With

For dx = 2 To cols
strCol = VBA.Split(Columns(dx).Address, "$")(2)

For cx = 2 To rws
If Cells(cx, dx) "" Then
rws2 = rws2 + 1
Sheets(2).Cells(rws2, 1).Value = Sheets(1).Cells(cx, 1).Value
Sheets(2).Cells(rws2, 2).Value = Sheets(1).Cells(cx, dx).Value
Sheets(1).Range(strCol + "1").Copy Destination:=Worksheets(2).Range("C" + Format(rws2))
').Cells(1, dx).Value

End If

Next cx
Next dx

Application.ScreenUpdating = True
MsgBox "转移完毕！"

End Sub

Answer 3

请问你说的是VB编程，还是excel带的VBA编程？

追问

不好意思，是excel肿的VBA编程

追答

代码如下。打开你的Excel文件，按“Alt+F11”打开VBA编辑窗口，然后在左侧对应的Sheet上双击，右侧空白处粘贴下面的代码。关闭VBA窗口。然后按“Alt+F8”打开宏窗口，选择刚插入的宏，点击“执行”。

结果会放在“生成结果”这张表中。

Sub ZY()
On Error Resume Next
Dim i, j, r, c, n As Long
n = 1
r = Cells(Rows.Count, "A").End(xlUp).Row
c = Cells(1, Columns.Count).End(xlToLeft).Column
If Sheets("生成结果") Is Nothing Then
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "生成结果"
Else
    Sheets("生成结果").Cells.ClearContents
End If
With Sheets("生成结果")
    .Range("A1").Resize(1, 3).Value = Array("PN", "QTY", "DATE")
    For i = 2 To c
        For j = 2 To r
            If Cells(j, i).Value <> "" Then
                n = n + 1
                Cells(j, 1).Copy .Cells(n, 1)
                Cells(j, i).Copy .Cells(n, 2)
                Cells(1, i).Copy .Cells(n, 3)
            End If
        Next
    Next
End With
End Sub

追问

哎呀，你的也一样好，只是先给别人了，好牛哦。是高手