This section of code should loop through the table of data in the column I tell it to, and if it is not 0 or blank it should copy the whole row of the table to another spreadsheet which is my formatted reports sheet.
This code seems good to me, and I have other similar pieces of code that work fine but this one does not for some reason.
Public Sub getActiveCodes()
Dim tRows
Dim i As Integer
Dim ws As Worksheet, rpts As Worksheet
Dim nxtRow As Integer
Set ws = Worksheets("Sheet1")
Set rpts = Worksheets("REPORTS")
For i = 1 To i = ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0_
Or "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial , Paste:=xlPasteValues
End If
Next i
End Sub
I would like this function to make a report of all data pertaining to each row item that is not zero in this column.
Cleaned up the code for you
Public Sub getActiveCodes()
Dim tRows
Dim i As Long, nxtRow As Long
Dim wb As Workbook
Dim ws As Worksheet, rpts As Worksheet
Set wb = Workbooks(REF)
Set ws = wb.Worksheets("Sheet1")
Set rpts = wb.Worksheets("REPORTS")
For i = 1 To ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0 _
Or ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial xlPasteValues
End If
Next i
End Sub
Problem was your underscore and the general If statement. Before a line break, add a space. Moreover you shouldn't do If x = 1 Or 2, you should always include the value you compare it to, so If x = 1 Or x = 2. That is because If x = 1 Or 2 reads as if x = 1 is true or if 2 is true, which will always be true because whether or not x = 1, there is nothing false about the number 2 on its own.
Using the Copy function to just copy values is slow. You're better off equalising the values of two ranges like Range("A1:A20").Value = Range("B2:B21").Value
Related
I have this error with my macro. My macro takes data from a table and in another sheet, outputs in a table my data for each value of a third sheet.
So let's say my table's value are : Jack and Daniel. And on my third sheet, I have Football and Rugby. The output in the second page will be :
Jack Football
Jack Rugby
Daniel Football
Daniel Rugby
Here is my macro :
Sub yo()
Dim Letters, Chk, Ele As Range, i As Long: Letters = Sheets("Sports").Range("C3:C5").Value
For Each Ele In Sheets("Students").ListObjects(1).ListColumns(1).DataBodyRange
With Sheets("OK").ListObjects(1)
Chk = Application.Match(Ele, .ListColumns(1).Range, 0)
If IsError(Chk) Then
For i = 1 To 3
.ListRows.Add.Range = Array(Ele, Letters(i, 1))
Next i
End If
End With
Next Ele
End Sub
However this works fine. The problem comes from all the other columns of the table in my second sheet. They all get the value "#NA". So instead of having nothing or formulas expanding down, there is that error.
How can I overcome this error ?
Copy to Excel Table (ListObject)
The short answer is that in this case a ListRow has four columns yet you're assigning it an array of only two. By the looks of your answer, you have concluded this yourself (.Resize(, 2)).
An Improvement
Option Explicit
Sub AddStudents()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsSports As Worksheet: Set wsSports = wb.Sheets("Sports")
Dim Sports(): Sports = wsSports.Range("C3:C5").Value
Dim SportsCount As Long: SportsCount = UBound(Sports, 1)
Dim wsStudents As Worksheet: Set wsStudents = wb.Sheets("Students")
Dim loStudents As ListObject: Set loStudents = wsStudents.ListObjects(1)
Dim lcStudents As ListColumn: Set lcStudents = loStudents.ListColumns(1)
Dim rgStudents As Range: Set rgStudents = lcStudents.DataBodyRange
Dim wsOK As Worksheet: Set wsOK = wb.Sheets("OK")
Dim loOK As ListObject: Set loOK = wsOK.ListObjects(1)
Dim lcOK As ListColumn: Set lcOK = loOK.ListColumns(1)
Dim rgOK As Range: Set rgOK = lcOK.DataBodyRange
Dim cell As Range, Student, MatchOK, r As Long, IsNotStudentAdded As Boolean
For Each cell In rgStudents.Cells
If rgOK Is Nothing Then
IsNotStudentAdded = True
Else
MatchOK = Application.Match(cell.Value, rgOK, 0)
If IsError(MatchOK) Then IsNotStudentAdded = True
End If
If IsNotStudentAdded Then
Student = cell.Value
For r = 1 To SportsCount
loOK.ListRows.Add.Range.Resize(, 2).Value _
= Array(Student, Sports(r, 1))
Next r
IsNotStudentAdded = False
Set rgOK = lcOK.DataBodyRange
End If
Next cell
MsgBox "Students added.", vbInformation
End Sub
So I decided to completely change my macro to avoid any error :
Sub Macro7()
Dim N, S, i, j
Application.ScreenUpdating = False
N = Range("Tableau1"): S = Sheets("Sports").Range("C3:C5").Value
With Range("Tableau2").ListObject
If .ListRows.Count > 0 Then .DataBodyRange.Delete
For Each i In N
For Each j In S
.ListRows.Add.Range.Resize(, 2) = Array(i, j)
Next
Next
End With
End Sub
From Sheet1 and Sheet2, if a cell from B column has "In Progress", then I want to copy that entire row to another Sheet4.
I want to repeat it for all rows of both the sheets.
Sub Demo1()
Dim wb As Workbook
Dim ws As Worksheet, sh As Worksheet
Dim lastrow As Long
Dim w As Integer
Dim i As Integer
Set wb = Workbooks(Book1)
Set ws = Worksheets("Sheet4")
Set sh = ActiveSheet
For w = 1 To wb.Sheets.Count
For i = 1 To lastrow
If ActiveSheetCells(i, 2).Value = "In Progress" Then
wb.ws.Cells(1, 1).Insert
Else
If Cells(i, 2).Value = "" And i < 50 Then
ActiveCell.Offset(1, 0).Select
End If
Cells(i, 2).Value = "" And i > 49
Next i
Next w
End Sub
Error Message
Sheet 1
Sheet 2
Sheet 3
Quick review on your code, based on my comments to the post (untested):
Sub Demo1()
Dim wb As Workbook: Set wb = Workbooks("Book1")
Dim destinationSheet As Worksheet: Set destinationSheet = wb.Worksheets("Sheet4")
Dim sourceSheet As Worksheet: Set sourceSheet = ActiveSheet
With sourceSheet
Dim lastRowSource As Long: lastRowSource = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim w As Long, i As Long
For w = 1 To wb.Sheets.Count
For i = 1 To lastRowSource
If .Cells(i, 2).Value = "In Progress" Then
destinationSheet.Cells(1, 1).Insert
Else
If .Cells(i, 2).Value = "" And i < 50 Then
'Why are you Selecting and what are you doing with it?
.Cells(i,X).Offset(1, 0).Select 'Change from "activeCell" to an actual cell reference as you don't change the activecell when looping...
End If
Cells(i, 2).Value = "" And i > 49 'Is this supposed to be another If statement?
End If 'Added
Next i
Next w
End With
Don't use Integer, use Long; the prior gets converted within VBA so you can save the processing with using the latter.
Use descriptive variable names so you're not lost in 10 months re-looking at your code, or having someone else look at your code. For the most part, people should be able to understand what's happening without the use of excessive comments.
Do your best to not have a wall of variables. If you can dimension a variable just as it's being used, you're pairing things together and might catch that x as long when you're using it as a string a lot faster.
You have a .Select and nothing happens with that. Additionally, included as a comment, using ActiveCell is probably not what you want... use a direct cell reference. Note that when you loop, VBA will change its references, however it does not physically change its activecell.
You have what appears to be another If statement which does not include any If / Then for the i > 49 bit.
The culprit of your error is the lack of End If, which is now placed with the comment Added.
I have made this code to create an output sheet where columns from different sheets are sorted by header name and pasted one after the other.
For some reason, it is not pasting the columns underneath each other, but instead overwriting each one with the next:
Dim ws As worksheet
Dim max_ws As worksheet
Dim output_ws As worksheet
Dim max_ws_header As Range
Dim output_ws_header As Range
Dim header_cell As Range
Dim cc As Long
Dim max_cc As Long
Dim output_header_counter As Long
Dim ws_header_counter As Long
Dim output_header_name As String
Dim ws_header_name As String
Application.DisplayAlerts = False
Sheets("indice").Delete
Sheets("aneca").Delete
Application.DisplayAlerts = True
For Each ws In Worksheets
ws.Rows(1).EntireRow.Delete
ws.Columns.Hidden = False
Next ws
max_cc = 0
For Each ws In Worksheets
cc = last_column_index(ws, 1)
If cc > max_cc Then
max_cc = cc
Set max_ws = ws
End If
Next ws
Sheets.Add.Name = "Output"
Set output_ws = Sheets("Output")
Set max_ws_header = max_ws.Range(max_ws.Cells(1, 1), max_ws.Cells(1, max_cc))
Set output_ws_header = output_ws.Range(output_ws.Cells(1, 1), output_ws.Cells(1, max_cc))
max_ws_header.Copy output_ws_header
For Each ws In Worksheets
If ws.Name <> "Output" Then
For output_header_counter = 1 To max_cc
output_header_name = output_ws.Cells(1, output_header_counter).Value
For ws_header_counter = 1 To max_cc
ws_header_name = ws.Cells(1, ws_header_counter).Value
If ws_header_name = output_header_name Then
ws.Range(Cells(1, ws_header_counter), Cells(last_row_index(ws, ws_header_counter), ws_header_counter)).Copy _
output_ws.Range(Cells(last_row_index(output_ws, output_header_counter) + 1, output_header_counter), Cells(last_row_index(ws, ws_header_counter), output_header_counter))
End If
Next ws_header_counter
Next output_header_counter
End If
The functions last_row_index and last_column_index are UDFs that I made as follows:
Function last_row_index(target_worksheet As worksheet, target_column_index As Long) As Long
last_row_index = target_worksheet.Cells(Rows.Count, target_column_index).End(xlUp).Row
End Function
Function last_column_index(target_worksheet As worksheet, target_row_index As Long) As Long
last_column_index = target_worksheet.Cells(target_row_index, Columns.Count).End(xlToLeft).Column
End Function
Here is an example of the output:
I figured out the solution, posting it here to close the question:
For Each ws In Worksheets
If ws.Name <> "Output" And ws.Name <> "indice" And ws.Name <> "aneca" Then
For row_index = 2 To last_row_index(ws, 1)
output_counter = last_row_index(output_ws, 1)
For column_index = 1 To last_column_index(ws, 1)
ws_header = ws.Cells(1, column_index).Value
For o_column_index = 1 To max_cc
output_header = output_ws.Cells(1, o_column_index).Value
If output_header = ws_header Then
ws.Cells(row_index, column_index).Copy output_ws.Cells(output_counter + 1, column_index)
Exit For
End If
Next o_column_index
Next column_index
Next row_index
End If
Next ws
I made an output counter variable and made it find the last row each time it starts on a new row in the input sheets, and then I add +1 to it every time it pastes a row.
I would like to delete all empty columns between 2 used ranges, based on the screenshot:
However, these two used ranges may have varying column length, thus the empty columns are not always Columns D to K.
Here is my code:
Sub MyColumns()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open ("BOOK2.xlsx")
Workbooks("BOOK2.xlsx").Activate
Workbooks("BOOK2.xlsx").Sheets(1).Activate
Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, 4).Value = "NON-EMPTY"
Dim finalfilledcolumn As Long
finalfilledcolumn = Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Dim iCol As Long
Dim i As Long
iCol = firstfilledcolumn + 1
'Loop to delete empty columns
For i = 1 To firstfilledcolumn + 1
Columns(iCol).EntireColumn.Delete
Next i
Workbooks("BOOK2.xlsx").Close SaveChanges:=True
MsgBox "DONE!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
However, the empty columns still remain.
Do note that the last filled column for the first used range, Place = "USA", Price = "110" and Category = "Mechanical" may not be fixed at Column C, but could go to Column D, E, etc.
Many thanks!
Please, try the next way:
Sub deleteEmptyColumn()
Dim sh As Worksheet, lastCol As Long, rngColDel As Range, i As Long
Set sh = ActiveSheet 'use here your necessary sheet, having the workbook open
'if not open, you can handle this part...
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column
For i = 1 To lastCol
If WorksheetFunction.CountA(sh.Columns(i)) = 0 Then
If rngColDel Is Nothing Then
Set rngColDel = sh.cells(1, i)
Else
Set rngColDel = Union(rngColDel, sh.cells(1, i))
End If
End If
Next i
If Not rngColDel Is Nothing Then rngColDel.EntireColumn.Delete
End Sub
Try this ..
Dim rng As Range, i As Long
Set rng = Workbooks("BOOK2.xlsx").Sheets(1).UsedRange
For i = rng.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(rng.Columns(i)) = 0 Then
rng.Columns(i).EntireColumn.Delete
End If
Next i
Im trying to copy and paste my data and assign them into different worksheets.For example, if column F is martin 1, the entire row that has martin1 will be paste to worksheets("Index1"). Same thing for Charlie 1 and it will be paste to worksheets("Index2"). However, I faced with a object defined error here as shown in my code below. Any ideas how to solve it?
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Dim i As Integer
Dim site_i As Worksheet
For i = 1 To 3
Set site_i = Sheets.Add(after:=Sheets(Worksheets.count))
site_i.Name = "Index" & CStr(i)
Next i
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value = "Martin1" Then
ws.Range(sCel, ws.Cells(rwNbr, 6)).EntireRow.Copy Destination:=Sheets("Index1").Range("A1")
ElseIf ws.Cells(rwNbr, 6).Value = "Charlie1" Then
ws.Range(sCel, ws.Cells(rwNbr - ws.UsedRange.Rows.count, 6)).EntireRow.CopyDestination:=Sheets("Index2").Range("A1") '<----application defined or object defined error here
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
This is the link to my worksheet. https://www.dropbox.com/home?preview=Sample+-+Copy.xlsm
The final output should look something like this...
If your raw data does not have a header row then I would use a loop to gather up your target cells and copy them accordingly.
You will need to update your 3 target values inside Arr to Charlie1, Martin1, etc.
Macro Steps
Loop through each name in Arr
Loop through each row in Sheet1
Add target row to a Union (collection of cells)
Copy the Union to the target sheet where target Sheet Index # = Arr position + 1
Sub Filt()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim Arr: Arr = Array("Value1", "Value2", "Value3")
Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Create 3 Sheets, move them to the end, rename
For x = 1 To 3
Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
cs.Name = "Index" & x
Next x
lr = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
'Loop through each name in array
For Target = LBound(Arr) To UBound(Arr)
'Loop through each row
For i = 1 To lr
'Create Union of target rows
If ws.Range("F" & i) = Arr(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, ws.Range("F" & i))
Else
Set CopyMe = ws.Range("F" & i)
End If
End If
Next i
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Index" & Target + 1).Range("A1")
Set CopyMe = Nothing
End If
Next Target
End Sub
Tested and working as expected on my end, however....
If you had headers this would be much easier with a copy/paste. If you run the same macro on same book twice this will break for many reasons such as having duplicated sheet names, breaking the relationship between Sheet Index # = Arr Position + 1, etc...