My code begins with assigning the sheet and grabbing the row count
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
lastRow22 As Long
lastRow22 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
I have the following which put the entire column into an array from column 1 to 80
Dim arrEntireWs2() as Variant
With ws2
arrEntireWs2 = .Range(.Cells(2,1),.Cells(lastRow22,80)).Value
End With
Then I loop through it
Dim lngArrEntireWs2Index as Long
For lngArrEntireWs2Index = LBound(arrEntireWs2,1) to Ubound(arrEntireWs2,1)
'Things I want to do
Next lngArrEntireWs2Index
My question is how do I grab the value at a certain column on the row that it is looping through? Like how would I grab what is on column 10 while going through the loop?
This is what youre looking for....
Dim lngArrEntireWs2Index as Long
For lngArrEntireWs2Index = LBound(arrEntireWs2,1) to Ubound(arrEntireWs2,1)
If arrEntireWs2(lngArrEntireWs2Index, 10) Then
debug.print; arrEntireWs2(lngArrEntireWs2Index, 10)
End if
Next lngArrEntireWs2Index
this looks better to me
Dim ws2 as workbook
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim arr2 as Variant
With ws2
arr2 = .UsedRange
End With
Dim i as Long
For i= LBound(arr2,1) to Ubound(arr2,1)
If arr2(i, 11) Then
debug.print; arr2(i, 11)
End if
Next i
Related
i need a macro to select some objects (rows) of the big database with over 500 rows and copy 12 of the 44 columns into an array and reorder them into an comparison table. I need the column headers reordered as row headers.
The goal is to export the new ordered comparison table into an existing powerpoint template. I will try to not copy the entire columns and just to copy the columns i need.
I'm new to Vba and would appreciate any help.
This is my code for reading the data so far:
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Myarray As Variant
Dim LastRow As Integer, LastColumn As Integer
Dim StartCells As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1") Google Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set StartCell = ws1.Range("A1")
LastRow = ws1.Cells(ws1.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = ws1.Cells(StartCell.Row,ws1.Columns.Count).End(xlToLeft).Column
My fake dataset is like this:
You said I need the column headers reordered as row headers. so you need to transpose.
In my code I'm using columns 2,5,6 and 8 but you can change this easily.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Myarray() As Variant
Dim LastRow As Integer, LastColumn As Integer
Dim StartCell As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim i As Long
Dim j As Long
Set StartCell = ws1.Range("A1")
LastRow = ws1.Cells(ws1.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = ws1.Cells(StartCell.Row, ws1.Columns.Count).End(xlToLeft).Column
'copy specific columns into worksheet 2
j = 1
For i = 1 To LastColumn Step 1
Select Case i
Case 2, 5, 6, 8 'target columns to copy
With ws1
Myarray() = .Range(.Cells(1, i), .Cells(LastRow, i)).Value
End With
With ws2
.Range(.Cells(j, 1), .Cells(j, LastRow)) = Application.WorksheetFunction.Transpose(Myarray())
End With
j = j + 1
Case Else
End Select
Next i
Erase Myarray()
End Sub
Output I get:
Hey I am a trainee as an IT-Specialist and my trainer gave me a task to complete a macro for excel. (I don't know anything about VBA)
I have to check the cells in a column for the value 1. If there is a 1 I need to store that value in a array.
That's what I did till now.
Sub test()
Dim sht As Worksheet
Dim LastColumn As Long
Dim LastRow As Long
Dim MyArray() As Single
Set sht = ThisWorkbook.Worksheets("Tabelle1")
LastRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
MsgBox LastRow
MsgBox Join(MyArray)
End Sub
Sub createArray(x As Variant)
Dim sht As Worksheet
Dim LastRow As Long
Dim tempArray() As String
Dim rowVal As String
Dim MyArray() As Single
Dim i As Integer
Dim j As Integer
Dim rang As Range
Dim arrayEntry As String
Set sht = ThisWorkbook.Worksheets("Tabelle1")
Set rang = sht.Range("A:A") ' // SET RANGE TO LOOK FOR VALUES
LastRow = rang.SpecialCells(xlCellTypeLastCell).Row
arrayEntry = ""
For i = 1 To LastRow
If sht.Cells(i, 1).Value = x Then ' // (i, 1) <---- '1' references column A -
change to numerical column that you want to loop through
If arrayEntry = "" Then
arrayEntry = x
rowVal = i
Else
arrayEntry = arrayEntry & "," & x
rowVal = rowVal & "," & i
End If
End If
Next i
tempArray = Split(arrayEntry, ",")
ReDim MyArray(UBound(tempArray))
For j = 0 To UBound(tempArray)
MyArray(j) = CInt(tempArray(j))
Next j
Erase tempArray
MsgBox LastRow
MsgBox arrayEntry
MsgBox rowVal
MsgBox (UBound(MyArray) + 1)
End Sub
I am unsure if you wanted the value '1' in the array or the row it appears on, swap x with i if you wanted the row number.
Sub TESTFORMULA()
createArray (1)
End Sub
I have the following problem: I imported a .csv file with my data into a separate worksheet called "Import".
In this QueryTable, I have the second column called "KW", which indicates the weeknumber for every row.
Now I wanted to populate an array with the cell values from the second column.
I need to make it dynamic, because the length of the array changes with each import.
So far I made the code below:
Sub PopulatingArrayVariable()
Dim myArray() As Variant
Dim TempArray() As Variant
Dim myTable As ListObject
Dim x As Long
Sheets("Import").Activate
Set myTable = ActiveSheet.ListObjects("database_all")
TempArray = myTable.DataBodyRange.Columns(2)
myArray = Application.Transpose(TempArray)
For x = LBound(myArray) To UBound(myArray)
Debug.Print myArray(x)
Next x
End Sub
I get the "runtime error 13": types not compatible
I get the error, but I don't know what exactly I need to change. Can someone please help me solve this?
Fix the Dim and use Set:
Sub PopulatingArrayVariable()
Dim myArray() As Variant '*** will be a 1D VBA array
Dim TempArray As Range '*** typical 2D range variable as part of a column
Dim myTable As ListObject
Dim x As Long
Sheets("Import").Activate
Set myTable = ActiveSheet.ListObjects("database_all")
Set TempArray = myTable.DataBodyRange.Columns(2)
myArray = Application.Transpose(TempArray)
For x = LBound(myArray) To UBound(myArray)
Debug.Print myArray(x)
Next x
End Sub
I would use an arraylist instead as it provides more flexibility. For example you can do something like this:
Sub test()
Dim arr As Object
Dim i As Long
Dim j As Long
Dim lastRow As Long
Set arr = CreateObject("System.Collections.ArrayList")
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
j = 2
'Filling arrayLists
For i = 2 To lastRow
arr.Add ActiveSheet.Cells(i, 2)
Next i
'Read from arrayLists
For i = 0 To arr.Count - 1
Cells(j, 3) = arr(i)
j = j + 1
Next i
End Sub
Customize the code as required. It should resolve your issue.
I'm searching a range in my sheet for certain values when either of these values is found I want to add the value from column A of that row to an array, only adding values that are not already present in the array. Once the range has been searched, I want to print the arrays to specified cells in the worksheet in 2 different columns.
Here's my code so far:
Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
Dim Leave() As Variant, Join() As Variant
Dim LastCol As Integer, LastRow As Integer, i As Integer, Z As Integer
Dim J As Long, L As Long
With Sheets("Sheet1")
'Find Last Col
LastCol = Sheets("Sheet1").Cells(3, Columns.Count).End(xlToLeft).Column
'Find last Row
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRow = LastRow - 1
'ReDim Leave(1 To (LastRow - 1), LastCol)
'ReDim Join(1 To (LastRow - 1), LastCol)
For i = 5 To LastCol
For Z = 4 To LastRow
If Sheets("Sheet1").Cells(Z, i).Value = "0" Then
Leave(L) = Ws.Cells(Z, 1).Value
ElseIf Sheets("Sheet1").Cells(Z, i).Value = "-2" Then
Join(J) = Ws.Cells(Z, 1).Value
End If
Next Z
Next i
'Print array
End With
Thanks for any pointers/help in advance!
I believe this procedure accomplishes what you are looking for. You will need to modify the range in which you are searching and the destination sheet information, but the meat of the procedure is here:
Sub abc_Dictionary()
Dim oWS As Worksheet
Dim RangeToSearch As Range
Dim myCell As Range
Dim UniqueDict As Object
Set oWS = Worksheets("Sheet1")
Set RangeToSearch = oWS.Range("B1:B26") 'You can set this dynamically however you wish
Set UniqueDict = CreateObject("Scripting.Dictionary")
'Now we search the range for the given values.
For Each myCell In RangeToSearch
If (myCell.Text = "0" Or myCell.Text = "-2") And Not UniqueDict.exists(oWS.Range("A" & myCell.Row).Text) Then
UniqueDict.Add oWS.Range("A" & myCell.Row).Text, oWS.Range("A" & myCell.Row).Text
End If
Next
'Now we have a dictionary object with the unique values of column a
'So we just iterate and dump into Sheet2
Dim d As Variant
Dim Val As Variant
Dim DestRow As Integer
DestRow = 1 'This is the first row of data we will use on Sheet 2
d = UniqueDict.Items
For Each Val In d
Worksheets("Sheet2").Range("A" & DestRow).Value = Val
DestRow = DestRow + 1
Next
Set UniqueDict = Nothing
Set RangeToSearch = Nothing
Set oWS = Nothing
End Sub
I have an Excel sheet having 3000 columns and I need to convert this sheet in such a way that one tab will contain 254 columns only and remaining will go to the next tab. So I need a VBA code (Macro) which can perform the same.
As of now I wrote the following code only which is creating 3000 tabs with one column in each, also it is going to infinite loop as I did not put any condition there for blank column.
Sub SpliteIntoMultipleTab()
'
' createtemplates Macro
Dim WS As Worksheet
Dim SS As Worksheet
Dim TemplateName As String
Dim tempstr As String
'
Dim CurCol As String
Dim Template As String
Dim xColIndex As Integer
Dim xRowIndex As Integer
Dim WSCount As Integer
'==========================================================================
'Declarations
CurCol = 1
Template = "Sheet1"
'==========================================================================
Set SS = Worksheets(Template)
If WS Is Nothing Then
Start:
With ActiveWorkbook
Set WS = .Sheets.Add(After:=ActiveSheet)
WSCount = Sheets.Add(After:=Sheets(Worksheets.Count))
On Error Resume Next
Set WS = Worksheets("temp")
WS.Name = SS.Range("A1").Value
End With
Else
End If
SS.Activate
xIndex = Application.ActiveCell.Column
xRowIndex = Application.ActiveSheet.Cells(Rows.Count, xIndex).End(xlUp).Row
Range(Cells(1, xIndex), Cells(xRowIndex, xIndex)).Select
Selection.Copy
WS.Select
WS.Range("A1").Select
ActiveSheet.Paste
SS.Columns(1).EntireColumn.Delete
CurCol = CurCol + 1
GoTo Start
End Sub
Use integer division and modulus, so for example taking the 1000th column
1000 \ 254 = 3
1000 mod 254 = 238
gives the 3rd sheet and the 238th column.
So loop through from 1 to 3000 using \ and mod.
You code is very non-standard and I cannot get my head around it, I suggest you start from my code, this is an illustrative example of breaking a block of data into separate sheets. Copy the code into a new workbook then
Run CreateSheetAndPopulateWithBlockOfData once only to create a block of data.
Run Test to run the BreakBlockIntoChunks routine, you can experiment with the chunk size.
Option Explicit
Private Const csSHEETNAME As String = "Source"
Sub TestCreateSheetAndPopualteWithBlockOfData()
Dim wsSource As Excel.Worksheet
Set wsSource = CreateSheetAndPopulateWithBlockOfData(ThisWorkbook, csSHEETNAME, 20, 100)
End Sub
Sub Test()
Dim wsSource As Excel.Worksheet
Set wsSource = ThisWorkbook.Worksheets.Item(csSHEETNAME)
'Stop
Dim wbResults As Excel.Workbook
Set wbResults = Workbooks.Add
BreakBlockIntoChunks wsSource, 5, wbResults
End Sub
Function BreakBlockIntoChunks(ByVal wsSource As Excel.Worksheet, ByVal lColumnChunkSize As Long, ByVal wbDestinationWorkbook As Excel.Workbook)
Dim rngDataBlock As Excel.Range
Set rngDataBlock = wsSource.Cells(1, 1).CurrentRegion
Dim lSourceColumnCount As Long
lSourceColumnCount = rngDataBlock.Columns.Count
Dim lSourceRowCount As Long
lSourceRowCount = rngDataBlock.Rows.Count
Dim lColumnLoop As Long
For lColumnLoop = 1 To lSourceColumnCount
Dim lCurrentSheet As Long
lCurrentSheet = ((lColumnLoop - 1) \ lColumnChunkSize) + 1
Dim wsCurrentSheet As Excel.Worksheet
If lCurrentSheet > wbDestinationWorkbook.Worksheets.Count Then Set wsCurrentSheet = wbDestinationWorkbook.Worksheets.Add
If wsCurrentSheet Is Nothing Then Set wsCurrentSheet = wbDestinationWorkbook.Worksheets.Item(lCurrentSheet) '* runs first loop
'**ADD your sheet naming logic here perhaps
Dim lCurrentColumn As Long
lCurrentColumn = ((lColumnLoop - 1) Mod lColumnChunkSize) + 1
Dim rngSource As Excel.Range
Set rngSource = wsSource.Range(wsSource.Cells(1, lColumnLoop), wsSource.Cells(lSourceRowCount, lColumnLoop))
Dim rngDestination As Excel.Range
Set rngDestination = wsCurrentSheet.Range(wsCurrentSheet.Cells(1, lCurrentColumn), wsCurrentSheet.Cells(lSourceRowCount, lCurrentColumn))
rngDestination.Value2 = rngSource.Value2 '* <---Copies without using clipboard
Next lColumnLoop
End Function
Function CreateSheetAndPopulateWithBlockOfData(ByVal wb As Excel.Workbook, ByVal sSheetName As String, ByVal lRowsDeep As Long, ByVal lColumnsWide As Long) As Excel.Worksheet
Dim ws As Excel.Worksheet
Set ws = wb.Worksheets.Add
ws.Name = sSheetName
Dim rngBlock As Excel.Range
Set rngBlock = ws.Range(ws.Cells(1, 1), ws.Cells(lRowsDeep, lColumnsWide))
rngBlock.Formula = "=RANDBETWEEN(1,100000)"
rngBlock.Value2 = rngBlock.Value2
Set CreateSheetAndPopulateWithBlockOfData = ws
End Function
you could try this:
Sub SpliteIntoMultipleTab()
Dim colNum As Long, iCol As Long
With Worksheets("Sheet1").UsedRange
colNum = .Columns.count
Do
Worksheets.Add(After:=Worksheets(Worksheets.count)).Range("A1:IT1").Resize(.Rows.count).Value = .Columns(iCol + 1).Resize(, 254).Value
iCol = iCol + 254
colNum = colNum - 254
Loop While colNum > 0
End With
End Sub
which copies values only and speed up things considerably