[英]Loop through rows and columns Excel Macro VBA
我在Excel工作表中有一列,其中包含以下格式的數據: aaa,bbbb,ccc,dd,eeee,...每個字符串都用逗號“,”分隔
我創建了一個宏,用於拆分A列中的數據,並將每個字符串分別插入到每一行的新單元格中,如屏幕截圖所示。
現在,我想計算B列之后的已用單元格數量,並根據該數字在單獨的行中重復B列中的值,然后將C,D,E等列中的下一個值添加到每一行...
最后,工作表2如下所示:
我創建了一個解決方案:
For i = 1 To 3
ActiveWorkbook.Sheets(2).Cells(i, 1).Value = ActiveWorkbook.Sheets(1).Range("B1").Value
ActiveWorkbook.Sheets(2).Cells(i, 2).Value = ActiveWorkbook.Sheets(1).Cells(1, i + 2).Value
Next i
但是,僅當列A僅具有一行時,它才起作用。 我已經嘗試過使用Loops使用不同的邏輯,但是仍然無法獲得正確的結果。 我有數百行,手動進行將很耗時。 請提出任何建議。 非常感謝你。
Sub ExtractParts()
Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet2")
Dim LastRow As Long: LastRow = wsSrc.UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim LastCol As Long: LastCol = wsSrc.UsedRange.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim i As Long, j As Long, RowCounter As Long: RowCounter = 2
With wsDest
.Cells(1, 1) = "Order Number"
.Cells(1, 2) = "Part Number"
For i = 1 To LastRow
For j = 3 To LastCol
If wsSrc.Cells(i, j) <> "" Then
.Cells(RowCounter, 1) = wsSrc.Cells(i, 2)
.Cells(RowCounter, 2) = wsSrc.Cells(i, j)
RowCounter = RowCounter + 1
End If
Next j
Next i
End With
End Sub
您可以使用Dictionary
方法
Sub main()
Dim cell As Range
Dim var As Variant
With CreateObject("Scripting.Dictionary") '<--| instantiate a 'Dictionary' object
For Each cell In Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").cells(Worksheets("Sheet1").Rows.Count, 1).End(xlUp)) '<-- loop through "Sheet1" column A cells from row 1 down to the last not empty one
var = Split(cell.Value, ",") '<--| store current cell content into an array, whose first element will be the 'key' of the dictionary
.item(var(0)) = Split(Replace(cell.Value, var(0) & ",", "", , 1), ",") '<--| update current 'key' dictionary item with the array of "remaining" values
Next
For Each var In .Keys '<--| loop through dictionary keys
Set cell = Worksheets("Sheet2").cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(.item(var)) + 1) '<--| set "Sheet2" range to start writing the current key values from
cell.Value = var '<--| write key
cell.Offset(, 1).Value = Application.Transpose(.item(var)) '<--| write current key values
Next
End With '<--| release 'Dictionary' object
End Sub
這是一種方法
Sub x()
Dim r As Long, c As Long
Application.ScreenUpdating = False
With Sheets(1)
For r = 1 To .Range("B" & Rows.Count).End(xlUp).Row
c = .Cells(r, Columns.Count).End(xlToLeft).Column - 2
.Cells(r, 2).Copy Sheets(2).Range("A" & Rows.Count).End(xlUp)(2).Resize(c)
.Cells(r, 3).Resize(, c).Copy
Sheets(2).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True
Next r
End With
Application.ScreenUpdating = True
End Sub
它已經被標記為已回答,但是我發現這個問題很有趣。 所以,這是我的貢獻。 這段代碼不需要將最初的內容分成多列,只需將一列用逗號分隔即可。
Dim rng As Range
Dim x As Variant
Dim i As Long
Dim offs As Long
offs = 1
Sheet2.Range("A1").Value = "Order Number"
Sheet2.Range("B1").Value = "Part Number"
For Each rng In Sheet1.Range("A:A")
If Trim(rng.Value) = "" Then End
x = Split(rng.Text, ",")
For i = 1 To UBound(x)
Sheet2.Range("A1").Offset(offs).Value = x(0)
Sheet2.Range("B1").Offset(offs).Value = x(i)
offs = offs + 1
Next i
Next rng
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.