continuation of my previous question. I think I've made some progress but gotten stuck again:
I've created two loops - one for month to be checked by user. Other will remain hidden but carries location of each file. I'd like it to pick values from the other file ("Training1" in each) and bring it to "2017 Actuals" of current file.
I've tested portions and I think I'm going wrong at the following which gives me a mismatch error, but any tips will be helpful:
Set wks = wkb.Sheets("Training1")
Full code here:
Private Sub UpdateActuals_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Dim p As Integer
Dim i As Integer
For i = 1 To 12
If Me.Controls("Month" & i).Value = True Then
For p = 1 To 12
Dim wkb As Workbook
Dim wks As Workbook
Set wkb = Workbooks.Open(Me.Controls("Location" & p))
Set wks = wkb.Sheets("Training1")
ThisWorkbook.Sheets("2017 Actuals").Range(i + 1, 5) = wks.Range("Start:Finish")
Next p
End If
Next i
wkb.Close
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
End Sub
You need to declare your wks as type Worksheet.
So in your block of code, update it to this:
If Me.Controls("Month" & i).Value = True Then
For p = 1 To 12
Dim wkb As Workbook
Dim wks As Worksheet ' Not Workbook
Set wkb = Workbooks.Open(Me.Controls("Location" & p))
Set wks = wkb.Sheets("Training1")
ThisWorkbook.Sheets("2017 Actuals").Range(i + 1, 5) = wks.Range("Start:Finish")
Next p
End If
Related
I am looking for VBA code that would look through several hundred Workbooks and open only ones that have "cash" in the workbook title. It would then pull the second row of the first worksheet down to the last row and append it to a master worksheet.
Although I see the iteration count reaches all one hundred plus workbooks, the code appends only the first few worksheets and stops. Could anyone provide insight as to why that is happening? Thank you in advance!
Sub Pull_Cash_WB_Names()
Dim filename As Variant
Dim a As Integer
a = 1
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim LRow As Long, LCol As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set wbDst = ThisWorkbook
strFilename = Dir("\\DATA\*Cash*")
Count = 0
Do While strFilename <> ""
Set wbSrc = Workbooks.Open("\\DATA\*Cash*")
Set wsSrc = wbSrc.Worksheets(1)
'copy all cells starting from 2nd row to last column
LRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
LCol = ActiveSheet.Cells(7, Columns.Count).End(xlToLeft).Column
Cells(2, 1).Resize(LRow - 1, LCol).Select
Selection.Copy
'paste the data into master file
wbDst.Sheets(wbDst.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'counts the number of iterations
Count = Count + 1
Application.StatusBar = Count
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
See fixes/suggestions below
Sub Pull_Cash_WB_Names()
Const PTH As string = "\\DATA\" 'folder path goes here
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim strFilename As String
Dim rngCopy AsRange, rngDest as range
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set wbDst = ThisWorkbook
Set rngDest = wbDst.Sheets(wbDst.Worksheets.Count).Range("A1") 'start pasting here
strFilename = Dir(PTH & "*Daily*Cash*.csv") '#EDIT#
Count = 0
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(PTH & strFilename) 'full path+name
Set rngCopy = wbSrc.Worksheets(1).Range("A1").CurrentRegion 'whole table
Set rngCopy = rngCopy.Offset(1, 0).resize(rngcopy.rows.count-1) 'exclude headers
rngCopy.Copy
'paste the data into master file
rngDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Set rngDest = rngDest.offset(rngCopy.rows.count) 'next paste goes here...
Count = Count + 1
Application.StatusBar = Count
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Hi all and thanks in advance.
I currently have a VBA within my workbook to copy rows from "Demand Log" to "Change Log" when cells within column "O" have a specific value.
The VBA is working great, however I am now looking to split the two worksheets apart and have a separate workbook for each.
My question is - How can I change my VBA so that it copies and pastes between workbooks as opposed to between worksheets?
Please see my VBA code below:
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Demand Log").UsedRange.Rows.Count
J = Worksheets("Change Log").Cells(Worksheets("Change Log").Rows.Count, "B").End(xlUp).Row
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Change Log").Range) = 0 Then J = 0
End If
Set xRg = Worksheets("Demand Log").Range("O5:O" & I)
Application.ScreenUpdating = False
For K = xRg.Count To 1 Step -1
If CStr(xRg(K).Value) = "Change Team" Then
J = J + 1
With Worksheets("Demand Log")
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Copy Destination:=Worksheets("Change Log").Range("A" & J)
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
End With
End If
Next
Application.ScreenUpdating = True
You should refer to your worksheets and workbooks at the same time. So, instead of:
I = Worksheets("Demand Log").UsedRange.Rows.Count
You should type:
I = Workbooks("Book1").Worksheets("Demand Log").UsedRange.Rows.Count
anywhere in your code. For simplicity, you may set object variable, like:
Dim wb1 as Workbook
Set wb1 = Application.Workbooks("Book1")
or, better, set your worksheets as variables, for example:
Dim wsDemand as Worksheet
Set wsDemand = Workbooks("Book1").Worksheets("Demand Log")
and then you can use wsDemand instead of Worksheets("Demand Log") anywhere in your code.
Book1 is of course default workbook's name, your file has probably other name.
If the workbook is open then you can refer to it like this:
Workbooks("mybook.xls")[.method]
If the workbook is closed you need to open it: Workbooks.Open("C:\path\mybook.xls")[.method]
You can assign them to variables:
set wb = Workbooks("mybook.xls")
set wb = Workbooks.Open("C:\path\mybook.xls")
set ws = wb.Sheets("MySheet")
You can also get to the worksheet and assign it to a variable: (useful if you're working with a single sheet)
set ws = Workbooks("mybook.xls").Sheets("MySheet")
set ws = Workbooks.Open("C:\path\mybook.xls").Sheets("MySheet")
Untested, but give it a try:
Sub mysub()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
Dim wbDem As Workbook
Dim wbChg As Workbook
Dim wsDem As Worksheet
Dim wsChg As Worksheet
'Open/Get Workbook
If Application.Workbooks("Demand.xls") Is Nothing Then
Set wbDem = Application.Workbooks.Open("C:\path\Demand.xls")
Else
Set wbDem = Application.Workbooks("Demand.xls")
End If
'Open/Get Workbook
If Application.Workbooks("Change") Is Nothing Then
Set wbChg = Application.Workbooks.Open("C:\path\Change.xls")
Else
Set wbChg = Application.Workbooks("Change.xls")
End If
'Set Sheet Variables
Set wsDem = wbDem.Worksheets("Demand Log")
Set wsChg = wbChg.Worksheets("Change Log")
I = wsDem.UsedRange.Rows.Count
J = wsChg.Cells(wbChg.Rows.Count, "B").End(xlUp).Row
If J = 1 Then
If Application.WorksheetFunction.CountA(wbChg.Range) = 0 Then J = 0
End If
Set xRg = wsDem.Range("O5:O" & I)
Application.ScreenUpdating = False
For K = xRg.Count To 1 Step -1
If CStr(xRg(K).value) = "Change Team" Then
J = J + 1
With wsDem
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Copy Destination:=wsChg.Range("A" & J)
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
End With
End If
Next
Application.ScreenUpdating = True
End Sub
I currently have code were I have a file of data with unique businesses, the vba that I have programmed removes all other businesses but one. I have noticed that the file that I have worked on has legacy data below the rows filled with data I need and I need to remove these to make the file smaller.
Sub ConstructionTools()
Dim ARange As Range
Dim DRange As Range
Dim ws As Worksheet
Dim wsB As Worksheet
Dim filename As String
Set ws = Sheets("Data")
Set wsB = Sheets("Macro")
Set DRange = Nothing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ARange In ws.Range("L1:L28000").Rows
If ARange(1).Value = "BUILDING CONSTRUCTION" Or ARange(1).Value = "CONSTRUCTION SERVICES" Or ARange(1).Value = "HEAVY & HIGHWAY" Or ARange(1).Value = "HEAVY CIVIL - SPS" Then
If DRange Is Nothing Then
Set DRange = ARange
Else
Set DRange = Union(DRange, ARange)
End If
End If
Next ARange
If Not DRange Is Nothing Then DRange.EntireRow.Delete
With ws.Rows(X & ":" & .Rows.Count).Delete
End With
End Sub
I put some code in from here How do I delete everything below row X in VBA/Excel?, but I am getting the
compile error Invalid or unqualified reference
The code worked before adding in this line
With ws.Rows(X & ":" & .Rows.Count).Delete
how would I go about deleting the rows behind the cleaned up data?
Option Explicit
Sub ConstructionTools()
'Dim ARange As Range
'Dim DRange As Range
Dim ws As Worksheet
'Dim wsB As Worksheet
'Dim filename As String
Set ws = Sheets("Data")
'Set wsB = Sheets("Macro")
'Set DRange = Nothing
Dim RowIndex as long
Dim Counter as long
With ws.Range("L1:L28000")
Dim RowsToDelete() as string
Redim rowstodelete(1 to .rows)
For rowindex = .rows to 1 step -1
Select case .cells(rowindex,1).value
Case "BUILDING CONSTRUCTION", "CONSTRUCTION SERVICES", "HEAVY & HIGHWAY" Or "HEAVY CIVIL - SPS"
Counter = counter + 1
Rowstodelete(counter) = .cells(rowindex,1).address
End select
Next rowindex
End with
If counter >0 then
Redim preserve RowsToDelete(1 to Counter)
With application
.screenupdating = false
.displayalerts = false
.calculation = xlcalculationmanual
Ws.range(strings.join(RowsToDelete,",")).entirerow.delete
.screenupdating = true
.displayalerts = true
.calculation = xlcalculationautomatic
End if
End sub
Untested and written on mobile, sorry for bad formatting. Code attempts to add the addresses of all rows which need to be deleted to an array, and then tries to delete all added rows in one go.
Good afternoon,
I am trying to read number of csv files and load them in a new workbook. Then created codes to find the largest number from each column (i.e. maximum value) and pasted in the bottom of each column. I have completed up to the stage of calcualting the largest value and pasting in the lastrow with the help of this forum.
Now I am trying to transfer them in a new worksheet that I created and named as result with my code. With previous suggestions I have figured out how to paste a specific range from one column to another worksheet with the following example:
Sub OneCell()
Sheets("Result").Range("E3:V3").Value = Sheets("HP5_1gs_120_2012.plt").Range("E3:V3").Value
End Sub
But not sure how can I loop this with my existing codes to read the last row where my max values are (highlighted in yellow in figure 1) and paste to the result sheet with the header from column E to the last available column and the rowname as the worksheet name. My data structure will be same for each worksheet for each run. And my start column is always column "E" but the end column (i.e. the last column) can be different for each run. THis is what I am getting really confused of how do I loop thorugh this. So for an example a simple dataset like below (Figure 1):
I am trying to achieve this (figure 2):
my main codes are as below:
Private Sub FilePath_Button_Click()
get_folder
End Sub
Private Sub Run_Button_Click()
load_file
End Sub
Public Sub get_folder()
Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
TextBox1.Text = FolderName
End Sub
Sub load_file()
Dim strFile As String
Dim ws As Worksheet
Dim test As String
Dim wb As Workbook
test = TextBox1.Text
strFile = Dir(Me.TextBox1.Text & "\*.csv")
Set wb = Workbooks.Add
'added workbook becomes the activeworkbook
With wb
Do While Len(strFile) > 0
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = strFile
With ws.QueryTables.Add(Connection:= _
"TEXT;" & test & "\" & strFile, Destination:=Range("$A$1"))
.Name = strFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
strFile = Dir
Loop
End With
Application.DisplayAlerts = False
Worksheets("Sheet1").Delete
Worksheets("Sheet2").Delete
Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
Dim ws1 As Worksheet
Dim ColNo As Long, lc As Long
Dim lastrow As Long
For Each ws1 In ActiveWorkbook.Worksheets
lastrow = Range("A1").End(xlDown).Row
lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
For ColNo = 5 To lc
ws1.Cells(lastrow + 2, ColNo).Formula = "=MAX(" & Split(Cells(, ColNo).Address, "$")(1) & "1:" & Split(Cells(, ColNo).Address, "$")(1) & lastrow & ")"
Next ColNo
Next ws1
Dim ws2 As Worksheet
Set ws2 = Sheets.Add
Sheets.Add.Name = "Result"
MsgBox "Job Complete"
End Sub
Private Sub UserForm_Click()
End Sub
I hope I have managed to explain what I am trying to acheive and I would really appreciate any guidence with this. Thanks
Something like the below should do it. No doubt you will want to tweak bits but the general structure is there. I have commented what each block is doing - make sure you understand each line.
But normally for asking questions you should really really break the question down into its parts.
Like - "How do I loop through sheets", then "How do I find the last row of a sheet", then "How do I copy ranges" etc.
You would find that every single one of those has been asked before so in fact a little searching of Stackoverflow would be all that is needed.
Sub example()
Dim ws As Worksheet, dWs As Worksheet 'variables for ws enumerator and destination ws
Dim wb As Workbook 'variable to define the workbook context
Dim sRng As Range, dRng As Range 'variables for source range and destination range
Set wb = ActiveWorkbook
'Add the results sheet and assign our current row range
Set dWs = wb.Worksheets.Add
Set dRng = dWs.Cells(2, 1)
'Change the results sheet name (error if name exists so trap it)
On Error Resume Next
dWs.Name = "Result"
On Error GoTo 0
'Loop worksheets
For Each ws In wb.Worksheets
'Only work on the .csv sheet names
If ws.Name Like "*.csv" Then
'Find the row with the values on
Set sRng = ws.Cells(ws.Rows.Count, 4).End(xlUp)
'And set the range to be to the contiguous cells to the right
Set sRng = ws.Range(sRng, sRng.End(xlToRight))
'Add the sheet name to the results col A
dRng.Value = ws.Name
'Copy sRng to the output range
sRng.Copy dRng(1, 2)
'Increment output row to the next one
Set dRng = dRng(2, 1)
End If
Next ws
'Now just add the headers
For Each dRng In dWs.Range(dWs.Cells(1, 2), dWs.Cells(1, dWs.Cells.Find("*", , XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious).Column))
dRng.Value = "data " & dRng.Column - 1
Next
End Sub
So what I'm trying to do is to update a list of worksheets based on the cell range in my source worksheet (same workbook). I know I could probably do this by deleting all the worksheets and adding new ones, but I need to have it where it takes out one and adds another.
Here is what I have so far, my problem started with the macros not responding when run or when I try to combine both macros so that I can link it to a button, nothing happens.
Sub Delete_Insert()
Dim i As Integer
i = 2
Dim ws As Worksheet
Dim stocks As Variant
Dim c_stocks As Integer
c_stocks = 7
Dim match As Boolean
'This is to see if a worksheet matched with a stock name
Dim j As Integer
j = 1
'To count the internal cell FOR loop
Application.DisplayAlerts = False
'This turns off the alert for deleting sheets
For Each ws In Worksheets
c = ActiveWorkbook.Worksheets.Count
match = False
For Each stocks In ThisWorkbook.Sheets("Main").Range("A2:A8").Cells
If CStr(stocks) = ActiveWorkbook.Sheets(i).name Then
match = True
Exit For
End If
Next stocks
If match = False Then
ws.Delete
End If
i = i + 1
If i = c Then
Exit For
End If
Next ws
End Sub`
And then this is to insert
For Each stocks In ThisWorkbook.Sheets("Main").Range("A2:A8").Cells
i = 2
match = False
For Each ws In Worksheets
If (ws.name = stocks) Then
match = True
Exit For
End If
i = i + 1
Next ws
If match = False Then
ActiveWorkbook.Worksheets.Add
ActiveSheet.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.name = CStr(stocks)
End If
j = j + 1
If (j = 7) Then
Exit For
End If
Next stocks
End Sub
Something like this (untested):
Sub Delete_Insert()
Dim i As Integer
Dim sht As Worksheet, wb As Workbook
Dim stocks As Range, c As Range, stck As String
Set wb = ActiveWorkbook
Set stocks = ThisWorkbook.Sheets("Main").Range("A2:A8")
'remove sheets not in list
For i = wb.Worksheets.Count To 1 Step -1
Set sht = wb.Worksheets(i)
If IsError(Application.match(sht.Name, stocks, 0)) Then
Application.DisplayAlerts = False
sht.Delete
Application.DisplayAlerts = False
End If
Next i
'add new sheets from list
For Each c In stocks.Cells
stck = c.Value
If Len(stck) > 0 Then
Set sht = Nothing
On Error Resume Next
Set sht = wb.Worksheets(stck)
On Error GoTo 0
If sht Is Nothing Then
With wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
.Name = stck
End With
End If
End If
Next c
End Sub