Here is my current code. It loops fine and enters the data I need but it does not stop when I would like it to. I need it to stop when it the cell in column B is found to be blank.
Sub Insert_Tasks_Info()
'
' Insert_Tasks_Info Macro
'
Dim counter As Integer
counter = 4
'runs macor until first empty cell in Column "B"
Do Until ThisWorkbook.Sheets("Data").Cells(counter, 2).Value = ""
'copies order task info and pastes into data tab
Sheets("Template").Select
Range("A4:G9").Select
Selection.Copy
Sheets("Data").Select
Range("A3").Select
Selection.End(xlDown).Select
NextFree = Range("A3:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).Select
Selection.Insert Shift:=xlDown
'copies hours info and pastes into data tab
Sheets("Template").Select
Range("F3:AA9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("F2").Select
Selection.End(xlDown).Select
NextFree = Range("F2:F" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("F" & NextFree).Select
ActiveSheet.Paste
Call Insert_Zone
counter = counter + 1
Loop
End Sub
Related
I am having trouble pasting.
I have written the code but when it gets to cell and selects it I have tried putting paste in but still does not work.
Code below, the starred bit is the issue
Sheets("Data").Select
If Range("A2") = "" Then
Range("A1").Paste
Else
Selection.End(xlDown).Select
ActiveCell. Offset(0, 1).Select
With Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
ActiveSheet.Range("$D$1:$D$50000").AutoFilter Field:=6, Criteria1:="B"
lastrow = Range("D" & Rows.Count).End(xlUp).Row
Range("D:M").SpecialCells(xlCellTypeVisible).Select
Set Rng = ActiveSheet.AutoFilter.Range
Windows("Pull Back Scans.xlsm").Activate
Sheets("Data").Select
If Range("A2") = "" Then
Range("A1").Paste
Else
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
With Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
**ActiveSheet.PasteSpecial**
Columns("A:J").Select
Columns("A:J").EntireColumn.AutoFit
Windows("Belfast CDC Scans.xlsb").Activate
ActiveWorkbook.Close savechanges:=False
End If
Columns("A:J").Select
Columns("A:J").EntireColumn.AutoFit
Windows("Belfast CDC Scans.xlsb").Activate
ActiveWorkbook.Close savechanges:=False
End If
I have a masterworkbook, which includes variable amount of Worksheets, which have Name as table1 and then the rest of the Sheets are called data, data(1), data(2) etc. I want to copy all the column&rows of the Sheets which has Name starting with "data" and paste this to worksheet called "Table1".
Can someone help me with this?
Based on the information, you could try something like this:
Sub getDataFromSheets()
'loop throug all sheets in workbook
For Each sh In ThisWorkbook.Worksheets
'check sheet name
If Left(sh.Name, 4) = "data" Then
With sh
'get last row on data sheet
'***** CHANGE THE COLUMN LETTER IF REQUIRED
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'get last row on table sheet
lRowTB = Sheets("Table1").Cells(Sheets("Table1").Rows.Count, "A").End(xlUp).Row + 1
'copy the data from data to table sheet
'***** ADJUST THE COLUMN LETTERS TO YOUR NEED *******
.Range("A1:E" & lRow).Copy Destination:=Sheets("Table1").Range("A" & lRowTB)
End With
End If
Next sh
End Sub
I made some additions to the codes and added the ability to take the subtotal of the desired column:
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("Grand_Table").Delete
Application.DisplayAlerts = True
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Grand_Table"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Last = FindLastRow(Sheets(1))
Selection.Copy
With Sheets(1).Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Next
'Application.CutCopyMode = False
Sheets("Grand_Table").Activate
Sheets("Grand_Table").UsedRange.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), _
Replace:=True, PageBreaks:=True, SummaryBelowData:=True
Good day,
I need help with a little problem. I have a macro which compares cell with range of cells. If the equal cell is not found, it will add the cell at the end of the range. My problem is with equal cell. If it finds it, I need to add 3 to column index and write "X" into this cell.
I have solution for unequal cell but i dont know how to increase column index and write into the cell.
I have this so far:
Sub Compare()
Dim i As Integer
'Comparing cell is from another workbook
Selection.Copy
Windows("zzz.xlsm").Activate
Range("A2").Select
ActiveSheet.Paste
i = 2
Do While Cells(i, 3).Value <> ""
Set FirstRange = Range("C" & i)
If FirstRange.Value = Cells(2, 1).Value Then
MsgBox "Found"
Exit Do
End If
i = i + 1
Loop
If MsgBox = True Then
'Missing code
Else
Range("A2").Select
Selection.Copy
ActiveSheet.Range("E" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End If
End Sub
I will appreciate any advice. Thank you for your time.
Sub Compare()
Dim i As Integer
'Comparing cell is from another workbook
Selection.Copy
Windows("zzz.xlsm").Activate
Range("A2").Select
ActiveSheet.Paste
i = 2
Do While Cells(i, 3).Value <> ""
Set FirstRange = Range("C" & i)
If FirstRange.Value = Cells(2, 1).Value Then
MsgBox "Found"
Exit Do
End If
i = i + 1
Loop
If MsgBox = True Then
Cells(i, 6) = "X" 'used to be Missing code
Else
Range("A2").Select
Selection.Copy
ActiveSheet.Range("E" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End If
End Sub
So I have now changed the macro below to this and am getting a
Runtime 1004 error at
ActiveSheet.Name = ShipperName
Code:
Sub CopyShipperToNewSheet()
Dim LR As Long
Dim ShipperName As String
' Last row of your data
LR = Range("A" & Cells.Rows.Count).End(xlUp).Row
' Loop Name range ( Column U)
For i = 2 To Range("U" & Cells.Rows.Count).End(xlUp).Row
ShipperName = Cells(i, 21)
' Use filter
Cells.Select
Selection.AutoFilter
' field =4 (column D----Shippers Name)
ActiveSheet.Range("$A$1:$S$" & LR).AutoFilter Field:=4, Criteria1:=ShipperName
' Copy visible cell
[A1].CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
' Paste to new sheet
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Name = ShipperName
' Go back sheet1
Sheets("Sheet1").Select
Selection.AutoFilter
Next i
End Sub
First get unique shipper name
The screenshot：
You can change this macro for yourself:
Sub CopyShipperToNewSheet()
Dim LR As Long
Dim ShipperName As String
' Last row of your data
LR = Range("A" & Cells.Rows.Count).End(xlUp).Row
' Loop Name range ( Column F)
For i = 2 To Range("F" & Cells.Rows.Count).End(xlUp).Row
ShipperName = Cells(i, 6)
' Use filter
Cells.Select
Selection.AutoFilter
' field =4 (column D----Name)
ActiveSheet.Range("$A$1:$D$" & LR).AutoFilter Field:=4, Criteria1:=ShipperName
' Copy visible cell
[A1].CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
' Paste to new sheet
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Name = ShipperName
' Go back sheet1
Sheets("Sheet1").Select
Selection.AutoFilter
Next i
End Sub
Hope this will help you.
My program works by calling a number of macros as such:
Sub Start()
Call ClearAll
Call Sales_Download
Call Copy_Sales
Call Receipt_Download
Call Copy_Receipt
Call Copy1
Call Sales_Summary
Call Copy2
Call Receipt_Summary
End Sub
My program breaks at the copy2, which is essentially an exact replica of copy1 wich works fine. When copy2 is ran by itself it works perfectly, but when I attempt to run the entire program it debugs. The bolded line is where the debug happens.
Sub Copy2()
' Copies all data from Receipt Download tab for each location, and saves in a seperate folder
Dim i As Long
Dim lngLastRow As Long, lngPasteRow As Long
'Find the last row to search through
lngLastRow = Sheets("Receipt_Download").Range("J65535").End(xlUp).Row
'Initialize the Paste Row
lngPasteRow = 2
Dim rng As Range
Dim c As Range
Dim endrow
Dim strName As String
Dim ws As Worksheet
Dim j As Long
endrow = Sheets("names").Range("A65000").End(xlUp).Row
Set rng = Sheets("names").Range("A2:A" & endrow)
j = 1
FBO = strName
For Each c In rng
For i = 2 To lngLastRow
strName = c.Value
If Sheets("Receipt_Download").Range("J" & i).Value = strName Then
Sheets("Receipt_Download").Select
Range("A" & i & ":IV" & i).Copy
Sheets("Summary").Select
Range("A" & lngPasteRow & ":IV" & lngPasteRow).Select
ActiveSheet.Paste
lngPasteRow = lngPasteRow + 1
End If
Next i
j = j + 1
Sheets("Receipt_Download").Select
Rows("1:1").Select
Selection.Copy
Sheets("Summary").Select
Rows("1:1").Select
ActiveSheet.Paste
Columns("D:E").Select
Selection.NumberFormat = "m/d/yyyy"
Sheets("Summary").Select
Range("B25000").Select
ActiveCell.FormulaR1C1 = "Grand Total"
Range("B25000").Select
Selection.Font.Bold = True
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=0,""0"",RC[-1])"
Range("G1").Select
Selection.AutoFill Destination:=Range("G1:G24950")
Range("G25000").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-24950]C:R[-1]C)"
Range("G25000").Select
Selection.Copy
Range("F25000").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("G:G").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Summary").Select
Range("F25000").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Names").Select
With Columns("B")
.Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate
End With
ActiveSheet.Paste
Sheets("Summary").Select
Range("b1:b30000").Select
For Each Cell In Selection
If Cell.Value = "" Then
Cell.ClearContents
End If
Next Cell
Range("b1:b30000").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheets("Summary").Select
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Names").Select
***With Columns("C")
.Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate***
End With
ActiveSheet.Paste
Sheets("Summary").Select
Range("A1:Z5000").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
File = "C:\Documents and Settings\user\Desktop\New FBO\" & strName & "\" & strName & " Receipts.xls"
ActiveWorkbook.SaveAs Filename:=File, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
IngPasteRow = IngPasteRow + 1
Sheets("Summary").Select
Selection.ClearContents
Next c
End Sub
I would really appreciate any help, I am certainly no VBA master and this has been quite troublesome.
Replace this part of your code
Sheets("Summary").Select
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Names").Select
With Columns("C")
.Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate
End With
ActiveSheet.Paste
with
Dim lRow As Long
With Sheets("Names")
lRow = .Range("C" & .Rows.Count).End(xlUp).Row + 1
Sheets("Summary").Range("D2").Copy .Range("C" & lRow)
End With
Now try it.
Also few tips
Avoid .Select and .Activate They are a major cause of errors
Indent and appropriately comment your code. Your code is very difficult to read. If you don't indent/comment your code, you will realize that you will not recognize your OWN code if you visit it say after a week :)
In support of Siddharth's answer above, I have take a portion of your code (up to where your break happens) and have indented and avoided the .Select and .Activate that he mentions. Hopefully this gives you a good start on how to make your code more readable for debugging and understanding.
For Each c In rng
For i = 2 To lngLastRow
strName = c.Value
If Sheets("Receipt_Download").Range("J" & i).Value = strName Then
Sheets("Receipt_Download").Range("A" & i & ":IV" & i).Copy _
Destination:=Sheets("Summary").Range("A" & lngPasteRow & ":IV" & lngPasteRow)
lngPasteRow = lngPasteRow + 1
End If
Next i
j = j + 1
Sheets("Receipt_Download").Rows("1:1").Copy Destination:=Sheets("Summary").Rows("1:1")
With Sheets("Summary")
.Columns("D:E").NumberFormat = "m/d/yyyy"
With .Range("B25000")
.Formula = "Grand Total"
.Font.Bold = True
End With
.Columns("G:G").Insert Shift:=xlToRight
With Range("G1")
.FormulaR1C1 = "=IF(RC[-2]=0,""0"",RC[-1])"
.AutoFill Destination:=Range("G1:G24950")
End With
With ("G25000")
.FormulaR1C1 = "=SUM(R[-24950]C:R[-1]C)"
.Copy
End With
.Range("F25000").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Columns("G:G").Delete Shift:=xlToLeft
.Range("F25000").Copy Destination:=Sheets("Names").Columns("B").Find(what:="", after:=Sheets("Names").Cells(1, 1), LookIn:=xlValues)
End With