transpose dynamic range exel VBA - excel

Question

having 25 columns and n number rows in sheet Input_Excel as in the image "DATA" and transposing the same into another sheet as in the image "Output" in my requited specific format . My code is working perfectly when the input_excel having minimal data and giving expected output where as the data being more than 2600 is giving bad output as in the image "Wrong"
I am hanging and struggling a lot to fix the issue. please help me to find out the problem in my below code. is there any maximum limit in handling arrays in excel VBA?
Correct me if am dealing any wrong method/calling. will be a great help and thanks in advance.
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
DATA
Output
Wrong

Answer 1

Transpose Data Range Using Arrays
Adjust the values in the constants section (Source, Target and Other).
I've added the headers to be copied to column "H". If you don't want them copied, remove the 3rd element (, "H") in tgtCols and delete the line Target(2)(k, 1) = Source(1, j).
The Code
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