Hi,
Require some help here.
I have a spreadsheet with 200 columns and 819 rows, where I want the records to come out in a set format, I had help here in the past to do that, it works fine if I keep the columns to '150' instead of '201' where it reads the data into an array but if I exceed it returns "Run-time error '1004': Application-defined or object-defined error", please see the VBA code and advise:
Require some help here.
I have a spreadsheet with 200 columns and 819 rows, where I want the records to come out in a set format, I had help here in the past to do that, it works fine if I keep the columns to '150' instead of '201' where it reads the data into an array but if I exceed it returns "Run-time error '1004': Application-defined or object-defined error", please see the VBA code and advise:
VBA Code:
Sub UnLineUp_v5()
Dim a As Variant, b As Variant
Dim i As Long, j As Long, k As Long, rowinc As Long, colinc As Long
Dim wbCSV As Workbook
'Read data into a array
a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 201).Value
'Make b array at least big enough to hold the results
ReDim b(1 To 4 * UBound(a), 1 To 203)
'Use k to identify the starting row for each new section in the b array
k = 1
'For each row of data
For i = 2 To UBound(a)
b(k, 1) = "ACCOUNT": b(k + 1, 1) = "ADDRESS": b(k + 2, 1) = "EDETAIL": b(k + 3, 1) = "ADDRESS"
For j = 1 To UBound(a, 2)
Select Case j
Case Is < 149: rowinc = 0: colinc = 0
Case Is < 177: rowinc = 1: colinc = 0
Case Is < 184: rowinc = 2: colinc = 0
Case Else: rowinc = 3: colinc = 0
End Select
'Enter the value into the b array
b(k + rowinc, 1 + j + colinc) = a(i, j)
Next j
'rowincrement k for next starting row
k = k + 4
Next i
Application.ScreenUpdating = False
'Create new workbook
Set wbCSV = Workbooks.Add
'Set range for top row of results
With wbCSV.Sheets(1).Range("A2").Resize(, UBound(b, 2))
'Enter headings & bold
.Offset(, 1).Resize(, .Columns.Count - 1).Value = a
.Font.Bold = True
'Enter balance of results
.Offset(1).Resize(UBound(b)).Value = b
'Remove unwanted rows
For i = UBound(b) To 1 Step -1
If .Cells(i, 202).End(xlToLeft).Column = 1 Then .Rows(i).EntireRow.Delete
Next i
.Cells(0, 1).Value = "This is a test , STANDARD 1.0"
.Cells(1, 1).Value = "LineType"
End With
'Save as CSV
wbCSV.SaveAs Filename:=ThisWorkbook.Path & "\" & "Test_File_" & Format(Now, "ddmmyyyyhhmm") & ".csv", FileFormat:=xlCSV
Application.ScreenUpdating = True
End Sub