vba
需求1 缺件
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False '关闭屏幕更新
Range("EL3:EL4000").ClearContents '清空指定区域
Dim i As Integer
Dim j As Integer
Dim a As Integer
Dim result As Integer
Dim temp As String
For i = 2 To 4000
a = Cells(i, 63) ' BK=63
For j = 66 To 103 ' BN=65 CY=103
temp = Cells(i, j).Value
If IsEmpty(temp) Or temp = "" Then
result = 0
Else
result = Cells(i, j).Value
End If
a = a - result
If a < 0 Then
Cells(i, 142).Value = Cells(1, j).Value '142=EL
Cells(i, 143).Value = -1 * a 'PM=143
Exit For
End If
If j = 103 Then
Cells(i, 142).Value = ""
End If
'以上三行代码为将不缺件缺件日期列赋值为空值
Next j
Next i
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
Private Sub CommandButton2_Click()
Cells(2, 142).Value = Cells(1, 103).Value
End Sub
需求2 转置
Sub TransposeAndReorganizeDataOptimized()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim data() As Variant
Dim targetData() As Variant
Dim i As Long, j As Long
Dim rowCounter As Long
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets(1) ' 假设数据在第一个工作表
' 创建目标工作表
Set wsTarget = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTarget.Name = "重组数据"
' 获取源数据的最后一行和最后一列
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' 读取源数据到数组
ReDim data(1 To lastRow, 1 To lastCol)
data = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).Value
' 初始化目标数据数组
ReDim targetData(1 To (lastRow - 1) * (lastCol - 5) + 1, 1 To 7)
' 写入新的标题行
targetData(1, 1) = "月订单号"""
targetData(1, 2) = "最大版本号"
targetData(1, 3) = "物料号"
targetData(1, 4) = "物料版本"
targetData(1, 5) = "物料名称"
targetData(1, 6) = "日期"
targetData(1, 7) = "数量"
' 初始化行计数器
rowCounter = 2 ' 目标工作表的起始行
' 转置并重组数据
For i = 2 To lastRow
For j = 6 To lastCol
targetData(rowCounter, 1) = data(i, 1)
targetData(rowCounter, 2) = data(i, 2)
targetData(rowCounter, 3) = data(i, 3)
targetData(rowCounter, 4) = data(i, 4)
targetData(rowCounter, 5) = data(i, 5)
targetData(rowCounter, 6) = data(1, j)
targetData(rowCounter, 7) = data(i, j)
rowCounter = rowCounter + 1
Next j
Next i
' 将目标数据数组写入目标工作表
wsTarget.Range("A1").Resize(rowCounter - 1, 7).Value = targetData
MsgBox "数据已成功重组并保存到新工作表！"
End Sub
备注：如何问ai
excel VBA 处理下列数据
处理之前：
手机 电脑 地域 年龄 备注 2024/1/1 2024/1/2 2024/1/3 2024/1/4 2024/1/5 2024/1/6 2024/1/7 2024/1/8 2024/1/9 2024/1/10
iso1 pc1 area1 age1 comment1 1204 7209 5748 4461 251 8964 1213 3088 7850 5124
iso2 pc2 area2 age2 comment2 8035 4564 4371 5369 499 7989 1771 8284 8727 2469
处理之后:
手机 电脑 地域 年龄 备注 日期 销售额
iso1 pc1 area1 age1 comment1 2024/1/1 1204
iso1 pc1 area1 age1 comment1 2024/1/2 7209
iso1 pc1 area1 age1 comment1 2024/1/3 5748
iso1 pc1 area1 age1 comment1 2024/1/4 4461
iso1 pc1 area1 age1 comment1 2024/1/5 251
iso1 pc1 area1 age1 comment1 2024/1/6 8964
iso1 pc1 area1 age1 comment1 2024/1/7 1213
iso1 pc1 area1 age1 comment1 2024/1/8 3088
iso1 pc1 area1 age1 comment1 2024/1/9 7850
iso1 pc1 area1 age1 comment1 2024/1/10 5124
iso2 pc2 area2 age2 comment2 2024/1/1 8035
iso2 pc2 area2 age2 comment2 2024/1/2 4564
iso2 pc2 area2 age2 comment2 2024/1/3 4371
iso2 pc2 area2 age2 comment2 2024/1/4 5369
iso2 pc2 area2 age2 comment2 2024/1/5 499
iso2 pc2 area2 age2 comment2 2024/1/6 7989
iso2 pc2 area2 age2 comment2 2024/1/7 1771
iso2 pc2 area2 age2 comment2 2024/1/8 8284
iso2 pc2 area2 age2 comment2 2024/1/9 8727
iso2 pc2 area2 age2 comment2 2024/1/10 2469
回答：
好的，根据你的需求，我们需要将宽表形式的数据转换为长表形式。以下是具体的VBA代码，用于实现这一转换：
1. 按 `Alt + F11` 打开VBA编辑器。
2. 在VBA编辑器中，点击“插入” > “模块”，插入一个新的模块。
3. 将下面的代码粘贴到新模块中：
Sub TransposeAndReorganizeData()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long, j As Long
Dim rowCounter As Long
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets(1) ' 假设数据在第一个工作表
' 创建目标工作表
Set wsTarget = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTarget.Name = "重组数据"
' 获取源数据的最后一行和最后一列
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' 复制标题行
wsSource.Range("A1:E1").Copy Destination:=wsTarget.Range("A1")
wsSource.Range("F1").Copy Destination:=wsTarget.Range("F1")
wsSource.Range("G1:O1").Copy Destination:=wsTarget.Range("G1")
' 写入新的标题行
wsTarget.Cells(1, 6).Value = "日期"
wsTarget.Cells(1, 7).Value = "销售额"
' 初始化行计数器
rowCounter = 2 ' 目标工作表的起始行
' 转置并重组数据
For i = 2 To lastRow
For j = 6 To lastCol
wsTarget.Cells(rowCounter, 1).Value = wsSource.Cells(i, 1).Value
wsTarget.Cells(rowCounter, 2).Value = wsSource.Cells(i, 2).Value
wsTarget.Cells(rowCounter, 3).Value = wsSource.Cells(i, 3).Value
wsTarget.Cells(rowCounter, 4).Value = wsSource.Cells(i, 4).Value
wsTarget.Cells(rowCounter, 5).Value = wsSource.Cells(i, 5).Value
wsTarget.Cells(rowCounter, 6).Value = wsSource.Cells(1, j).Value
wsTarget.Cells(rowCounter, 7).Value = wsSource.Cells(i, j).Value
rowCounter = rowCounter + 1
Next j
Next i
MsgBox "数据已成功重组并保存到新工作表！"
End Sub
4. 关闭VBA编辑器，返回Excel。
5. 按 `Alt + F8` 打开宏对话框，选择 `TransposeAndReorganizeData` 并运行。
这段代码会将源工作表中的数据转换为所需的长表形式，并保存到一个名为“重组数据”的新工作表中。请确保在运行宏之前备份您的原始数据，以防止任何意外的数据丢失或损坏。
再问：优化性能
优化代码性能
Sub TransposeAndReorganizeData()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long, j As Long
Dim rowCounter As Long
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets(1) ' 假设数据在第一个工作表
' 创建目标工作表
Set wsTarget = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTarget.Name = "重组数据"
' 获取源数据的最后一行和最后一列
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' 复制标题行
wsSource.Range("A1:E1").Copy Destination:=wsTarget.Range("A1")
wsSource.Range("F1").Copy Destination:=wsTarget.Range("F1")
wsSource.Range("G1:O1").Copy Destination:=wsTarget.Range("G1")
' 写入新的标题行
wsTarget.Cells(1, 6).Value = "日期"
wsTarget.Cells(1, 7).Value = "销售额"
' 初始化行计数器
rowCounter = 2 ' 目标工作表的起始行
' 转置并重组数据
For i = 2 To lastRow
For j = 6 To lastCol
wsTarget.Cells(rowCounter, 1).Value = wsSource.Cells(i, 1).Value
wsTarget.Cells(rowCounter, 2).Value = wsSource.Cells(i, 2).Value
wsTarget.Cells(rowCounter, 3).Value = wsSource.Cells(i, 3).Value
wsTarget.Cells(rowCounter, 4).Value = wsSource.Cells(i, 4).Value
wsTarget.Cells(rowCounter, 5).Value = wsSource.Cells(i, 5).Value
wsTarget.Cells(rowCounter, 6).Value = wsSource.Cells(1, j).Value
wsTarget.Cells(rowCounter, 7).Value = wsSource.Cells(i, j).Value
rowCounter = rowCounter + 1
Next j
Next i
MsgBox "数据已成功重组并保存到新工作表！"
End Sub
回答
这段VBA代码的主要目的是将源工作表中的数据进行转置和重组，然后将结果写入一个新的工作表中。为了提高代码的执行效率，可以考虑以下几点优化：
1. **减少重复操作**：避免多次调用相同的属性或方法。
2. **使用数组处理数据**：将数据读取到数组中，再一次性写入目标工作表，这样可以显著提升性能。
3. **减少对工作表的直接访问**：尽量减少对工作表的直接读写操作。
以下是优化后的代码示例：
Sub TransposeAndReorganizeDataOptimized()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim data() As Variant
Dim targetData() As Variant
Dim i As Long, j As Long
Dim rowCounter As Long
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets(1) ' 假设数据在第一个工作表
' 创建目标工作表
Set wsTarget = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTarget.Name = "重组数据"
' 获取源数据的最后一行和最后一列
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' 读取源数据到数组
ReDim data(1 To lastRow, 1 To lastCol)
data = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).Value
' 初始化目标数据数组
ReDim targetData(1 To (lastRow - 1) * (lastCol - 5) + 1, 1 To 7)
' 写入新的标题行
targetData(1, 1) = "A"
targetData(1, 2) = "B"
targetData(1, 3) = "C"
targetData(1, 4) = "D"
targetData(1, 5) = "E"
targetData(1, 6) = "日期"
targetData(1, 7) = "销售额"
' 初始化行计数器
rowCounter = 2 ' 目标工作表的起始行
' 转置并重组数据
For i = 2 To lastRow
For j = 6 To lastCol
targetData(rowCounter, 1) = data(i, 1)
targetData(rowCounter, 2) = data(i, 2)
targetData(rowCounter, 3) = data(i, 3)
targetData(rowCounter, 4) = data(i, 4)
targetData(rowCounter, 5) = data(i, 5)
targetData(rowCounter, 6) = data(1, j)
targetData(rowCounter, 7) = data(i, j)
rowCounter = rowCounter + 1
Next j
Next i
' 将目标数据数组写入目标工作表
wsTarget.Range("A1").Resize(rowCounter - 1, 7).Value = targetData
MsgBox "数据已成功重组并保存到新工作表！"
End Sub
### 主要改进点：
1. **使用数组存储数据**：通过将数据读取到数组中，减少了对工作表的直接读写操作，从而提高了性能。
2. **一次性写入数据**：将所有处理好的数据一次性写入目标工作表，而不是逐行写入，进一步提升了效率。
3. **减少重复操作**：例如，标题行的复制操作被简化为直接赋值给数组元素。
这些改动应该能显著提高代码的执行速度，特别是在处理大量数据时。
需求3 2的基础上过滤空或者值为0的行
Sub TransposeAndReorganizeDataOptimized()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim data() As Variant
Dim targetData() As Variant
Dim i As Long, j As Long
Dim rowCounter As Long
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets(1) ' 假设数据在第一个工作表
' 创建目标工作表
Set wsTarget = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTarget.Name = "重组数据4"
' 获取源数据的最后一行和最后一列
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' 读取源数据到数组
ReDim data(1 To lastRow, 1 To lastCol)
data = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).Value
' 初始化目标数据数组
ReDim targetData(1 To (lastRow - 1) * (lastCol - 5) + 1, 1 To 7)
' 写入新的标题行
targetData(1, 1) = "月订单号"""
targetData(1, 2) = "最大版本号"
targetData(1, 3) = "物料号"
targetData(1, 4) = "物料版本"
targetData(1, 5) = "物料名称"
targetData(1, 6) = "日期"
targetData(1, 7) = "数量"
' 初始化行计数器
rowCounter = 2 ' 目标工作表的起始行
' 转置并重组数据
For i = 2 To lastRow
For j = 6 To lastCol
targetData(rowCounter, 1) = data(i, 1)
targetData(rowCounter, 2) = data(i, 2)
targetData(rowCounter, 3) = data(i, 3)
targetData(rowCounter, 4) = data(i, 4)
targetData(rowCounter, 5) = data(i, 5)
targetData(rowCounter, 6) = data(1, j)
targetData(rowCounter, 7) = data(i, j)
rowCounter = rowCounter + 1
Next j
Next i
' 过滤掉第7列为空或为0的行
ReDim filteredData(1 To rowCounter - 1, 1 To 7)
filteredRowCounter = 1
For i = 1 To UBound(targetData, 1)
If targetData(i, 7) <> "" And targetData(i, 7) <> 0 And Not IsEmpty(targetData(i, 7)) Then
For j = 1 To 7
filteredData(filteredRowCounter, j) = targetData(i, j)
Next j
filteredRowCounter = filteredRowCounter + 1
End If
Next i
' 将目标数据数组写入目标工作表
wsTarget.Range("A1").Resize(rowCounter - 1, 7).Value = filteredData
MsgBox "数据已成功重组并保存到新工作表！"
End Sub
浙公网安备 33010602011771号