PDA

View Full Version : Trying to write a vba variant to an excel range which consists of a singular row and



TrinColll
06-11-2013, 01:18 PM
Hi I've gotten stuck trying to copy a vba variant to an excel range which is a singular row with multiple columns. Ive provided all of my code as I suspect I have declared my variants sizing in a way that is preventing my code from being run. At the moment it gets an application defined or object defined run time error. On the line

Sheets("IT DASH").Range(Cells(1, 2), Cells(1, UBound(IT))) = IT

Any Ideas would be great thanks!

Sub PopulateDash()
Dim IT As Variant
ReDim IT(1 to 1) As Variant

Dim RD As Variant
ReDim RD(1 To 1) As Variant

Dim QA As Variant
ReDim QA(1 To 1) As Variant

Dim QC As Variant
ReDim QC(1 To 1) As Variant

Dim Test As Variant
ReDim Test(1 To 1) As Variant

Dim Dev As Variant
ReDim Dev(1 To 1) As Variant

Dim PM As Variant
ReDim PM(1 To 1) As Variant

Dim Admin As Variant
ReDim Admin(1 To 1) As Variant

Dim HD As Variant
ReDim HD(1 To 1) As Variant


For Each chk In Sheets("SOP REQUIREMENTS").CheckBoxes

If chk.Value = Checked Then
Set cell = chk.TopLeftCell
Select Case cell.row
Case 2:
IT(UBound(IT)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve IT(1 To UBound(IT) + 1)
Case 3:
RD(UBound(RD)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve RD(1 To UBound(RD) + 1)
Case 4:
QA(UBound(QA)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve QA(1 To UBound(QA) + 1)
Case 5:
QC(UBound(QC)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve QC(1 To UBound(QC) + 1)
Case 6:
Test(UBound(Test)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve Test(1 To UBound(Test) + 1)
Case 7:
Dev(UBound(Dev)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve Dev(1 To UBound(Dev) + 1)
Case 8:
PM(UBound(PM)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve PM(1 To UBound(PM) + 1)
Case 9:
Admin(UBound(Admin)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve Admin(1 To UBound(Admin) + 1)
Case 10:
HD(UBound(HD)) = Sheets("SOP REQUIREMENTS").Cells(1, cell.Column).Value
ReDim Preserve HD(1 To UBound(HD) + 1)
End Select

Else


End If
Next

Sheets("IT DASH").Cells.ClearContents
Sheets("RD DASH").Cells.ClearContents
Sheets("QA DASH").Cells.ClearContents
Sheets("QC DASH").Cells.ClearContents
Sheets("Test DASH").Cells.ClearContents
Sheets("Dev DASH").Cells.ClearContents
Sheets("PM DASH").Cells.ClearContents
Sheets("Admin DASH").Cells.ClearContents
Sheets("HD DASH").Cells.ClearContents




Sheets("IT DASH").Range(Cells(1, 2), Cells(1, UBound(IT))) = IT
Sheets("RD DASH").Range(Cells(1, 2), Cells(1, UBound(RD))) = RD
Sheets("QA DASH").Range(Cells(1, 2), Cells(1, UBound(QA))) = QA
Sheets("QC DASH").Range(Cells(1, 2), Cells(1, UBound(QC))) = QC
Sheets("Test DASH").Range(Cells(1, 2), Cells(1, UBound(Test))) = Test
Sheets("Dev DASH").Range(Cells(1, 2), Cells(1, UBound(Dev))) = Dev
Sheets("PM DASH").Range(Cells(1, 2), Cells(1, UBound(PM))) = PM
Sheets("Admin DASH").Range(Cells(1, 2), Cells(1, UBound(Admin))) = Admin
Sheets("HD DASH").Range(Cells(1, 2), Cells(1, UBound(HD))) = HD

End Sub

p45cal
06-11-2013, 01:44 PM
Sheets("IT DASH").Range(Cells(1, 2), Cells(1, UBound(IT))) = IT needs to change to:Sheets("IT DASH").Range(Sheets("IT DASH").Cells(1, 2), Sheets("IT DASH").Cells(1, UBound(IT))) = IT

SamT
06-11-2013, 02:03 PM
I noticed that all the array values come from the same row(1).
Anyway...Try this
Option Explicit

Sub PopulateDash()

Dim IT(), RD(), QA(), QC(), Test()
Dim Dev(), PM(), Admin(), HD()

WithSheets ("SOP REQUIREMENTS")
For Each chk In .CheckBoxes

If chk = Checked Then
Set cell = chk.TopLeftCell
Select Case cell.Row
Case 2: IT(UBound(IT)) = .Cells(1, cell.Column).Value
ReDim Preserve IT(UBound(IT) + 1)
Case 3: RD(UBound(RD)) = .Cells(1, cell.Column).Value
ReDim Preserve RD(UBound(RD) + 1)
Case 4: QA(UBound(QA)) = .Cells(1, cell.Column).Value
ReDim Preserve QA(UBound(QA) + 1)
Case 5: QC(UBound(QC)) = .Cells(1, cell.Column).Value
ReDim Preserve QC(UBound(QC) + 1)
Case 6: Test(UBound(Test)) = .Cells(1, cell.Column).Value
ReDim Preserve Test(UBound(Test) + 1)
Case 7: Dev(UBound(Dev)) = .Cells(1, cell.Column).Value
ReDim Preserve Dev(UBound(Dev) + 1)
Case 8: PM(UBound(PM)) = .Cells(1, cell.Column).Value
ReDim Preserve PM(UBound(PM) + 1)
Case 9: Admin(UBound(Admin)) = .Cells(1, cell.Column).Value
ReDim Preserve Admin(UBound(Admin) + 1)
Case 10: HD(UBound(HD)) = .Cells(1, cell.Column).Value
ReDim Preserve HD(UBound(HD) + 1)
End Select
End If
Next
End With

Sheets("IT DASH").Cells.ClearContents
Sheets("RD DASH").Cells.ClearContents
Sheets("QA DASH").Cells.ClearContents
Sheets("QC DASH").Cells.ClearContents
Sheets("Test DASH").Cells.ClearContents
Sheets("Dev DASH").Cells.ClearContents
Sheets("PM DASH").Cells.ClearContents
Sheets("Admin DASH").Cells.ClearContents
Sheets("HD DASH").Cells.ClearContents

Resize


Sheets("IT DASH").Range("B1").Resize(, UBound(IT)) = IT
Sheets("RD DASH").Range("B1").Resize(, UBound(RD)) = RD
Sheets("QA DASH").Range("B1").Resize(, UBound(QA)) = QA
Sheets("QC DASH").Range("B1").Resize(, UBound(QC)) = QC
Sheets("Test DASH").Range("B1").Resize(, UBound(Test)) = Test
Sheets("Dev DASH").Range("B1").Resize(, UBound(Dev)) = Dev
Sheets("PM DASH").Range("B1").Resize(, UBound(PM)) = PM
Sheets("Admin DASH").Range("B1").Resize(, UBound(Admin)) = Admin
Sheets("HD DASH").Range("B1").Resize(, UBound(HD)) = HD

End Sub

TrinColll
06-12-2013, 09:06 AM
Sweet! Thanks Sam I got it to work using some of your code. I had to redim my variants after i declared them to have a dimension because otherwise UBound provided an error message!