时间戳

首页 > 解决方案 > 转置动态范围exel VBA

excel - 转置动态范围exel VBA

问题描述

在表格 Input_Excel 中有 25 列和 n 行，如图像“DATA”中所示，并以我要求的特定格式将其转换为另一张表格，如图像“Output”中所示。当 input_excel 具有最少的数据并给出预期的输出时，我的代码运行良好，因为数据超过 2600 给出了错误的输出，如图像“错误”中所示

我正在努力解决这个问题。请帮我找出下面代码中的问题。在excel VBA中处理数组有最大限制吗？如果处理任何错误的方法/调用，请纠正我。将是一个很大的帮助，并提前感谢。

Dim ws As Worksheet
Dim toWs As Worksheet
Dim vDB, vR()
Dim strShName As Variant
Dim r As Long, i As Long, n As Long, lastRow As Long, cc As Long, req_id As String
Dim k As Integer, j As Integer
Dim sc As Range, lr As Long, lc As Long, rg As Range, myRange As Range

Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False


Set ws = Sheets("Input Excel")
Set sc = ws.Range("A1")
lr = sc.SpecialCells(xlCellTypeLastCell).Row
lc = sc.SpecialCells(xlCellTypeLastCell).Column

strShName = ActiveSheet.Name

If strShName = "Data" Then
    Application.DisplayAlerts = False
Sheets("Data").Delete
    Application.DisplayAlerts = True
End If


Sheets.Add.Name = "Data"

Columns("A:c").Select
Selection.NumberFormat = "@"

Range("A1").Select

Set rg = ws.Range("A1").CurrentRegion
Set toWs = Sheets("Data") '<~~ Result Sheet

ws.Activate
Range("D1:Y1").Select
Selection.NumberFormat = "0"
Range("A1").Select
toWs.Activate

vDB = ws.Range(sc, ws.Cells(lr, lc)).Value

r = UBound(vDB, 1)
cc = ws.Range(sc, ws.Cells(lr, lc)).Columns.Count

For i = 2 To r
    If vDB(i, 1) <> "" Then ' row
        For j = 4 To cc
            n = n + 1
            ReDim Preserve vR(1 To cc, 1 To n)
                For k = 1 To 3
                    vR(k, n) = vDB(i, k)
                Next k
                vR(4, n) = vDB(1, j)
                vR(5, n) = vDB(i, j)
        Next j
    End If
Next i
With toWs
    .UsedRange.Offset(1).Clear
    .Range("A2").Resize(n, 10) = WorksheetFunction.Transpose(vR)
End With

Range("A3:C3").Select
Selection.Copy
Range("A2").Select
ActiveCell.PasteSpecial

Range("A1").Value = "Sales Org"
Range("B1").Value = "Soldto"
Range("C1").Value = "TE Part Number"
Range("D1").Value = "Demand_Date"
Range("E1").Value = "Values"

toWs.Select

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRange = Range("E2:E" & lastRow)

myRange.Select
    On Error GoTo eh
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
eh:
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRange = Range("d2:d" & lastRow)
Range("J1").Select
ActiveCell.FormulaR1C1 = "=IFERROR(FIND(""."",R[1]C[-6],1),0)"
Range("J1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

If Range("J1").Value > 0 Then
    myRange.Select
    Selection.Replace What:=".", Replacement:="/", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=True
End If

Range("J1").Select
Selection.ClearContents
Columns("E:E").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("E2").Select

ActiveCell.FormulaR1C1"=
DAY(RC[-1])&""/""&MONTH(RC[-1])&""/""&YEAR(RC[-1])"

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRange = Range("E2:E" & lastRow)

myRange.Select
Selection.FillDown
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks:=False, Transpose:=False
Range("D1").Select
Application.CutCopyMode = False
Selection.Copy
Range("E1").Select
ActiveSheet.Paste
Columns("D:D").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

Range("f2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=""NA"",RC[-5],IF(LEN(RC[-5])=
2,CONCAT(""00"",RC[-5]),IF(LEN(RC[-5])=3,
CONCAT(0,RC[-5]),IF(LEN(RC[-5])=1,CONCAT(""000"",RC[-5]),RC[-5]))))"

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRange = Range("F2:F" & lastRow)
myRange.Select
Selection.FillDown
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks:=False, Transpose:=False

myRange.Select
Selection.Copy
Range("A2").Select

ActiveSheet.Paste

Columns("F:f").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

Dim v As Integer

Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

Range("A:E").EntireColumn.AutoFit

req_id = InputBox("Please enter request ID which is generated in your 
application")

If req_id = "" Then
    Application.DisplayAlerts = False
    Sheets("Data").Delete
    Application.DisplayAlerts = True
End If
Sheets("SaveFile").Select
End If
Range("F1").Select
ActiveCell.FormulaR1C1 = "Case_ID"

Range("F2").Select
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRange = Range("F2:F" & lastRow)
myRange.Value = req_id

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRange = Range("A1:F" & lastRow)
myRange.Select

Dim t As Integer

If t = 0 Then
Dim tbl As ListObject
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
tbl.TableStyle = "TableStyleMedium15"
End If

t = 1

Set myRange = Range("A2:B" & lastRow)

myRange.Replace What:="NA", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


Range("D1").Value = "Demand_Date"


Dim DTAddress As String
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
ActiveWorkbook.SaveAs Filename:=DTAddress & req_id & 
"_Upload_LTF_Monthly", FileFormat:=6

MsgBox "Please check file is saved in your desktop and upload the same 
desktop saved file"

ws.Activate
Range("D1:Y1").Select
Selection.NumberFormat = "mmm-yy"
Range("A1").Select
toWs.Activate

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
'ActiveWorkbook.Close False
End Sub

数据

数据

输出

输出

错误的

错误的

标签： excelvba

解决方案

使用数组转置数据范围

  • 调整常量部分 ( 和 ) 中Source的Target值Other。
  • 我已将要复制的标题添加到“H”列。如果您不想复制它们，请删除其中的第三个元素 ( , "H")tgtCols并删除该行Target(2)(k, 1) = Source(1, j)。

编码

Option Explicit

Sub transposeDataOnly()
    
    ' Source
    Const srcName As String = "Input_Excel"
    Const srcFirstCell As String = "A1"
    Const srcFirstCol As Long = 3
    ' Target
    Const tgtName As String = "Data"
    Dim tgtCols As Variant
    tgtCols = VBA.Array("C", "E", "H") ' 'VBA' ensures zero-based.
    Const tgtFirstRow As Long = 2
    ' Other
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    ' Write values from Source Range to Source Array.
    Dim src As Worksheet
    Set src = wb.Worksheets(srcName)
    Dim Source As Variant
    Source = src.Range(srcFirstCell).CurrentRegion.Value
    
    ' Define Jagged Target Array.
    Dim ubC As Long: ubC = UBound(tgtCols)
    Dim Target As Variant: ReDim Target(0 To ubC)
    Dim ubS1 As Long: ubS1 = UBound(Source, 1)
    Dim ubS2 As Long: ubS2 = UBound(Source, 2)
    Dim Help As Variant
    ReDim Help(1 To (ubS1 - 1) * (ubS2 - srcFirstCol), 1 To 1)
    Dim j As Long ' Columns Array Element Counter, Source Array Columns Counter
    For j = 0 To ubC
        Target(j) = Help
    Next j
    
    ' Write values from Source Array to arrays of Jagged Target Array.
    Dim i As Long ' Source Array Rows Counter
    Dim k As Long ' Arrays of Jagged Target Array Rows Counter
    For i = 2 To ubS1
        If Not IsEmpty(Source(i, srcFirstCol)) Then
            For j = srcFirstCol + 1 To ubS2
                If Not IsEmpty(Source(i, j)) Then
                    k = k + 1
                    Target(0)(k, 1) = Source(i, srcFirstCol) ' TE Part Number
                    Target(1)(k, 1) = Source(i, j)           ' Values
                    Target(2)(k, 1) = Source(1, j)           ' Headers
                End If
            Next j
        End If
    Next i
    
    ' Write values from Jagged Target Array to Target Range.
    Dim tgt As Worksheet
    Set tgt = wb.Worksheets(tgtName)
    'tgt.Cells.ClearContents
    For j = 0 To ubC
        tgt.Cells(tgtFirstRow, tgtCols(j)).Resize(k).Value = Target(j)
    Next j

End Sub

推荐阅读