New to forum and very new to VBA. I'm trying to consolidate data off hundreds of forms I get every month. I have to grab a few extra fields off the forms (names, dates, stores) and fill down alongside the other columns. I've run into the error of when there is only one row of data and can't autofill. I've tried to work around this with an IF, Then, Else. What happens is after it hits a file that has that one row, it will not do the autofill on any subsequent files with more than one. It almost works.
Code:
Sub test()
Dim FolderPath As String
Dim FileName As String
Dim wb As Excel.Workbook
Dim Erow
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
FolderPath = "C:\Users\Test\"
FileName = Dir(FolderPath & "*.xlsx")
Do While FileName <> ""
Workbooks.Open (FolderPath & FileName)
Range("B10").Select
Selection.Copy
Range("K17").Select
ActiveSheet.Paste
Range("J9").Select
Application.CutCopyMode = False
Selection.Copy
Range("L17").Select
ActiveSheet.Paste
Range("J11").Select
Selection.Copy
Range("M17").Select
ActiveSheet.Paste
Dim lastRow As Long
If lastRow > 17 Then
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("K17").AutoFill Destination:=Range("K17:K" & lastRow),
Type:=xlFillCopy
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("L17").AutoFill Destination:=Range("L17:L" & lastRow),
Type:=xlFillCopy
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("M17").AutoFill Destination:=Range("M17:M" & lastRow),
Type:=xlFillCopy
Else
ActiveWorkbook.Save
Range("A17:M200").Copy
ActiveWorkbook.Close
End If
Erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(Erow, 1), Cells(Erow, 13))
FileName = Dir
Loop
End Sub
Here is a screenshot of what happens after the "one row" file.
Error After One Row, Auto Fill stops
The problem arises from having the calculation for the lastrow within the IF statement. The lastrow is only recalculates when lastRow > 17 from the previous workbook.
Calculate lastrow before the IF statement, so that you're looking at the lastrow of the current workbook each time.
Related
All of the variables are defined correctly. This works till it gets to the final statement shown and then it says
"Paste method of Worksheet class failed".
Set TargetSheet = ActiveSheet
For Each cell In TargetSheet.Columns(1).Cells
If IsEmpty(cell) = True Then FirstRow = cell.Row: Exit For
Next cell
LastRow = FirstRow + 6
Sheets(ClientName).Range("A3:Q9").Copy
With Sheets("4 Policies")
.Activate
.Range("A" & FirstRow).Select
ActiveSheet.Paste Link:=True
End With
Try this
Set TargetSheet = ActiveSheet
For Each cell In TargetSheet.Columns(1).Cells
If IsEmpty(cell) = True Then FirstRow = cell.Row: Exit For
Next cell
LastRow = FirstRow + 6
Sheets("4 Policies").Range("A" & FirstRow).Resize(7, 17).Formula = "=" & ClientName & "!A3"
If you trying to find the cell below the last used one in column A, your code becomes
FirstRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheets("4 Policies").Range("A" & FirstRow).Resize(7, 17).Formula = "=" & ClientName & "!A3"
or, if the active sheet is "4 Policies"
ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(7, 17).Formula = "=" & ClientName & "!A3"
I'm trying to copy all rows with data from one sheet into another.
I get a runtime error at the selection.paste line.
Sub move_rows2()
Dim i As Integer, countSheets As Integer, rowCount As Integer
countSheets = Application.Sheets.Count
For i = 1 To countSheets
Worksheets(i + 1).Select
Range("A" & Rows.Count).End(xlUp).Select
rowCount = ActiveCell.Row
Rows("1:" & rowCount).Select
Range("A" & rowCount).Activate
Selection.Copy
Worksheets(1).Select
Range("A" & Rows.Count).End(xlUp).Select
Selection.Offset(2, 0).Select
Selection.Paste
Next i
End Sub
Without the select/activate, and using an explicit workbook reference.
Dim i As Long, wb As Workbook
Set wb = ActiveWorkbook
For i = 2 To wb.Sheets.Count
With wb.Sheets(i)
.Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Copy _
wb.Sheets(1).Cells(.Rows.Count, 1).End(xlUp).Offset(2, 0)
End With
Next i
I wrote this code and it keeps giving me an error that the size of the copy area and the paste area are not the same.
but if I just use the copy-paste method, it works perfectly. could you pls help me out.
Sub copy()
eRow = Sheet5.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheet4.Range("a4", "d23").copy
Sheet5.Cells(eRow, 1).PasteSpecial (xlPasteValues)
End Sub
Move values one by one with a value transfer. As implied in the name, a value transfer does not carry over formats.
This just copies the 2 individual cells A4 & D23
Sub copy_me()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1).Row
ws.Range("A" & lr).Value = ws.Range("A4").Value
ws.Range("D" & lr).Value = ws.Range("D23").Value
End Sub
If you meant to grab the entire range A4:D23 then
ws.Range("A4:D23").Copy
ws.Range("A" & lr).PasteSpecial xlPasteValues
OR
ws.Range("A" & lr).Resize(20, 4).Value = ws.Range("A4:D23").Value
I'm having some issues with last row expression and autofill. I'm not sure what I'm missing here as it looks correct but it doesn't seem to be starting the vlookup in the proper cell (N2, it starts it in N1) and it won't autofill to the last row of M. Any push in the right direction would be greatly appreciated. I'm thinking it's something small I'm overlooking.
Sub Nightly()
'
' Nightly Macro
'
Dim PackSpec As Workbook
Dim FullBook As Workbook
Dim DebFile As Workbook
Dim lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
'Open the nightly pack spec file, cut and insert the year row into column D
Set PackSpec = Workbooks.Open("S:\Accounting\Apps\Packspec\CIDExport\Archive\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date) - 1 & "\*.csv")
Columns("A:A").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Range("A2").Select
'Open Fullbook master and insert columns after N then VLookup between Pack Spec and Fullbook
Set FullBook = Workbooks.Open("S:\Corporate\Groups\Comosoft\Downloads\FullBook\fullbook_Master.csv")
Columns("N:U").Select
Selection.Insert Shift:=xlToRight
Range("N2").Select
'Actvate Fullbook and enter Vlookup for dates
Windows("fullbook_Master.csv").Activate
With ActiveSheet.Range("N2")
.FormulaR1C1 = "=VLOOKUP(RC[-1],'[15.50.1.CID.csv]15.50.1.CID'!C[-13]:C[-11],3,0)"
.AutoFill Destination:=Range("N2:N" & lrow) 'issue not autofilling to end
Windows("fullBook_Master.csv").Activate
End With
End Sub
Just move the
lrow = Cells(Rows.Count, 1).End(xlUp).Row
after
Windows("fullbook_Master.csv").Activate
You should:
Link lrow to a sheet to avoid mistakes.
Avoid all the selects.
Sub Nightly()
'
' Nightly Macro
'
Dim PackSpec As Workbook
Dim FullBook As Workbook
Dim DebFile As Workbook
Dim lrow As Long
Dim ws As Worksheet, wsPackSpec As Worksheet
Set ws = Activesheet
'Or set ws = Sheets("Sheet1") - better
'Open the nightly pack spec file, cut and insert the year row into column D
Set PackSpec = Workbooks.Open("S:\Accounting\Apps\Packspec\CIDExport\Archive\" &
Year(Date) & "\" & Month(Date) & "\" & Day(Date) - 1 & "\*.csv")
Set wsPackSpec = PackSpec.Sheets(1)
wsPackSpec.Columns(1).Value = wsPackSpec.Columns(4).Value
wsPackSpec.Columns(1).EntireColumn.Delete
'Open Fullbook master and insert columns after N then VLookup between Pack Spec and Fullbook
'Apply same principle as above here
Set FullBook = Workbooks.Open("S:\Corporate\Groups\Comosoft\Downloads\FullBook\fullbook_Master.csv")
Columns("N:U").Select
Selection.Insert Shift:=xlToRight
Range("N2").Select
'Actvate Fullbook and enter Vlookup for dates
Windows("fullbook_Master.csv").Activate
Set ws = ActiveSheet 'Set like this, but you should designate the correct worksheet in the fullbook part above
lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
With ws
.Cells(2, 14).FormulaR1C1 = "=VLOOKUP(RC[-1],'[15.50.1.CID.csv]15.50.1.CID'!C[-13]:C[-11],3,0)"
.Cells(2, 14).AutoFill Destination:=.Range(.Cells(2, 14), .Cells(lrow, 14))
End With
End Sub
Something like this, couldn't test in detail because I'm missing the overview of how the books are set up.
I have the VBA code setup to delete rows, format columns, add a heading, etc. Now I need this code to be repeated on each Sheet in the Workbook. Some Workbooks will have 1 sheet, some could have dozens. I've looked at various answers, but can't find something that works.
Here is a snippet of the code I need to have repeated on each sheet:
Sub C_FormattingWTitle_Step3_do_on_each_tab()
'Delete all blank empty rows
Dim FirstBlankCell As Long, rngFound As Range
With ActiveSheet
Set rngFound = .Columns("G:G").Find("*", After:=.Range("G1"), searchdirection:=xlPrevious, LookIn:=xlValues)
If Not rngFound Is Nothing Then FirstBlankCell = rngFound.Row
End With
If ActiveCell.SpecialCells(xlLastCell) <> rngFound Then
Selection.SpecialCells(xlCellTypeBlanks).Select
ActiveWindow.SmallScroll Down:=9
Selection.EntireRow.Delete
Else
Range("A1").Select
End If
'Remove all not 260563 or header in SiteID column
Dim LR As Long, i As Long
LR = Range("G" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
If Not (Range("G" & i).Value Like "260563") And Not (Range("G" & i).Value Like "SiteID") Then Rows(i).Delete
Next i
'Remove all False values and header in Sign in Success column
Dim FR As Long, p As Long
FR = Range("F" & Rows.Count).End(xlUp).Row
For p = FR To 2 Step -1
If Not (Range("F" & p).Value Like True) And Not (Range("F" & p).Value Like "SignInSuccess") Then Rows(p).Delete
Next p
'Remove shading and formatting from header row
Rows("1:1").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Format date/time
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy hh:mm:ss;#"
After the code is run on every sheet, I want to insert Save As code. Any help would be greatly appreciated.
Use a separate sub to call and execute that subroutine:
Dim wkst As Worksheet
For Each wkst In ActiveWorkbook.Worksheets
Call C_FormattingWTitle_Step3_do_on_each_tab(wkst)
Next