搜尋+轉置貼上的函數公式 - Excelㄧ般區

[發問] 搜尋+轉置貼上的函數公式

2^# 跳轉到 »

發表於 2021-1-6 23:06 | 只看該作者

本帖最後由 luhpro 於 2021-1-6 23:09 編輯

測試檔︰
需求a︰
當工作表A的B2︰B51=空白時，則將其同列A欄的值，轉置貼上工作表B的B104︰AX104
當工 ...
ziv976688 發表於 2021-1-5 18:22

儲存格公式我始終不是看得很懂,
依據你短消息所說我這裡提供VBA程式的解決方式,
試試看.

Sub Tran()
Dim iI1%, iI2%
Dim lSum&, lRow%
Dim shSou As Worksheet, shTar As Worksheet
Set shSou = Worksheets("A")
Set shTar = Worksheets("B")
With shTar
.Range(.[B104], .[AX268]).ClearContents
End With
With shSou
For iI2 = 0 To 1
For lRow = 2 To 18
lSum = 0
For iI1 = 2 To 51
lSum = lSum + Cells(lRow, iI1)
Next
If lSum = 0 Then
Debug.Print iI2 * 39 + lRow & " , " & 102 + iI2 * 98 + lRow
.Cells(iI2 * 39 + lRow, 1).Resize(50).Copy
shTar.Cells(102 + iI2 * 98 + lRow, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
End If
Next
For lRow = 2 To 19
lSum = 0
For iI1 = 2 To 51
lSum = lSum + Cells(lRow, iI1)
Next
If lSum = 0 Then
Debug.Print iI2 * 39 + 19 + lRow & " , " & 151 + iI2 * 98 + lRow
.Cells(iI2 * 39 + 19 + lRow, 1).Resize(50).Copy
shTar.Cells(151 + iI2 * 98 + lRow, 2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
End If
Next
Next
End With
End Sub

複製代碼

靜思自在 : 地上種了菜，就不易長草；心中有善，就不易生惡。