Extracting data from a specifc worksheet to a new workbook - vba

I'm currently having problems trying to extract cell data and pasting them into a new workbook. To make things clearer here are the steps
Access a specific worksheet ("Report") in all open workbooks (except the one running the macro)
From the worksheet, extract certain cell data (no. of rows and columns are not fixed but they are identical throughout the open workbooks)
Create a new workbook and paste the data there (each workbook will be assigned one row in the sheet, and all data extracted will be on the same sheet)
I'm having problems with my last sub that extracts this cell data and pastes it into a new workbook, here's what I have so far:
Function Extract_Report_Final(wb As Workbook, book As workbook, counter as long)
Dim last_row, last_col As Long
Dim ws As Worksheet
Dim i, j, k As Integer
Dim data() As String
With wb.Sheets("Report") 'for each worksheet in each open workbook
last_row = .Range("C" & .Rows.Count).End(xlUp).Row
last_col = .Cells(last_row, .Columns.Count).End(xlToLeft).Column
'to get the last row and column where the data required will be located
'this is identical throughout the workbooks as is the name of the worksheet
ReDim data(last_col - 1)
'I decided to use an array to store the values as i don't know how else :(
For k = 0 To (last_col - 2)
Select Case k
Case 0: data(k) = .Cells(1, 1).Value
Case 1: data(k) = .Cells(last_row, 3).Value
Case Else: data(k) = .Cells(last_row, k + 2).Value
End Select
Next k
k = 0
'A weak attempt at trying to copy.paste the values onto a new workbook
'I also don't know how to reference a newly created workbook :(
For i = 1 To last_col
'"book" is the variable workbook which will house the extracted data
.book.ws.Cells(counter, i) = data(k)
k = k + 1
Next i
End Function
Below is my main sub:
Sub Cycle_wb()
Dim ws As Worksheet
Dim wb As Workbook
Dim book As Workbook
Dim counter As Long, last_row As Long, last_col As Long
Dim i, j, k As Integer
Dim data() As String
counter = 1
open_close
Query_Tv_values
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then
MsgBox "working on " & wb.Name
PerLineItem2 wb
Threshold_Value_PayFull wb
End If
Next
'It's just the part below which I'm having issues with :(
Set book = Workbooks.Add
Set ws = book.Sheets.Add(book.Sheets(1))
ws.Name = "Report_Final"
For Each wb In Workbooks
If (wb.Name <> ThisWorkbook.Name Or wb.Name <> book.Name) Then
Extract_Report_Final wb, counter, book
counter = counter + 1
Next wb
End Sub

Just use something like this to fill out the values in your new workbook
Cells(counter, i).Value = data(i-1)
Check the size of you array vs the length of your loops though - I think the "i"-loop should go
For i = 1 To last_col -1

Related

Finding the sum of values in one workbook based on a single criteria in another workbook

I've been writing a code that uses 3 workbooks - but I am having issues with the final output.
workbook 1 (wb1 - this workbook - where the macro is run on - and the final code will be displayed)
workbook 2 (wb2) which is a customer database for product orders
workbook 3 (wb3) which is a reference file for weights (to be manipulated in workbook 2)
wb1 opens up wb2 and wb3, cross-references (using VLOOKUP) the weights in wb3, copies them over to the corresponding customer address in wb2, then multiples the weights by the quantity ordered in wb2's address line.
The entire code works as I planned, except for the final output. wb2 now has the final weights in column Q.
All that is left is for the "PO Number" in wb1 (column K) to lookup the multiple "PO Number"s in wb2 (column C as well)
Sum wb2's weights (column Q) where there is a match
Return that sum back to wb1. I've tried sumif, but to no avail.
Here is the final output code (it returns no values at the moment), with the entire code posted below for reference.
'Enter in the weights data into the final sheet
tempCount = 0
lastCount = lastRow1
For tempCount = 1 To lastCount
Set lookFor = wb1.Sheets(1).Cells(tempCount + 1, 11) ' value to find
Set lookForRange = wb2.Sheets(1).Range("$C$2:$C$" & lastRow2) 'Range of values to lookup
Set srchRange = wb2.Sheets(1).Range("$Q$7:$Q$" & lastRow2)
wb1.Sheets(1).Activate
ActiveSheet.Cells(tempCount + 1, 12).Value = Application.WorksheetFuction.SumIf(lookForRange, lookFor, srchRange)
On Error Resume Next
Next
Below is the entire code for reference.
'Define workbooks
Dim wb2FileName As Variant
Dim wb3FileName As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim wb3 As Workbook
'Count last rows in columns
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim lastRow3 As Long
'Variables
Dim lookFor As Range
Dim lookForRange As Range
Dim srchRange As Range
Dim tempCount As Integer
Dim lastCount As Integer
'Open up all workbooks to work on
Set wb1 = ThisWorkbook
wb2FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Customer Order Data Worksheet", MultiSelect:=False)
If wb2FileName <> False Then
Workbooks.Open Filename:=wb2FileName
End If
Set wb2 = Workbooks.Open(wb2FileName)
wb3FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Source Reference File (Weights)", MultiSelect:=False)
If wb3FileName <> False Then
Workbooks.Open Filename:=wb3FileName
End If
Set wb3 = Workbooks.Open(wb3FileName)
'Find the last row in the customer data workbook and the source weights workbook
wb2.Sheets(1).Activate
lastRow2 = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
wb3.Sheets(1).Activate
lastRow3 = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
'Use VLOOKUP to enter in weights from the reference sheet into the customer order data sheet, then multiply by the quantity
tempCount = 0
lastCount = lastRow2
For tempCount = 1 To lastCount
Set lookFor = wb2.Sheets(1).Cells(tempCount + 6, 10) ' value to find
Set srchRange = wb3.Sheets(1).Range("$B$2:$C$" & lastRow3) 'source
wb2.Sheets(1).Activate
ActiveSheet.Cells(tempCount + 6, 16).Value = Application.WorksheetFunction.VLookup(lookFor, srchRange, 2, False)
ActiveSheet.Cells(tempCount + 6, 17).Value = ActiveSheet.Cells(tempCount + 6, 11).Value * ActiveSheet.Cells(tempCount + 6, 16).Value
On Error Resume Next
Next
'Delete top 5 rows from the final sheet and insert new header
wb1.Sheets(1).Activate
ActiveSheet.Rows("1:5").Delete
ActiveSheet.Cells(1, 12).Value = "Weights"
'Find the last row on the final sheet
lastRow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Enter in the weights data into the final sheet
tempCount = 0
lastCount = lastRow1
For tempCount = 1 To lastCount
Set lookFor = wb1.Sheets(1).Cells(tempCount + 1, 11) ' value to find
Set lookForRange = wb2.Sheets(1).Range("$C$2:$C$" & lastRow2) 'Range of values to lookup
Set srchRange = wb2.Sheets(1).Range("$Q$7:$Q$" & lastRow2)
wb1.Sheets(1).Activate
ActiveSheet.Cells(tempCount + 1, 12).Value = Application.WorksheetFuction.SumIf(lookForRange, lookFor, srchRange)
Next
Okay, I made several additions/changes to your code, so bear with me.
I added Option Explicit to the top of your module (you might already have it but you didn't include your Sub/End Sub so we couldn't tell).
Got rid of Activate & ActiveSheet. This just leads to a plethora of possible errors and a loss in readability. Use explicit references instead.
You need a way to Exit Sub if one of your wb2 or wb3 return False. If they do they'll just throw an error. Now you'll get a MsgBox and the subroutine will exit appropriately.
Got rid of On Error Resume Next. You shouldn't need that here. If you have to use it, at least turn errors back on by using On Error GoTo 0 soon after.
Moved some Sets inside their corrresponding If statements, and moved a couple static Sets outside of a loop (if it's always the same, why put it inside the loop?).
Now, for your issue with the SumIf - I believe you're encountering this issue because your criteria range and your sum range are not the same size. When they aren't, you can get a return of 0 because they don't line up properly. I've changed Range("$Q$7:$Q$" & lastRow2) to Range("$Q$2:$Q$" & lastRow2) in hopes that fixes that (but you might need to change Range("$C$2:$C$" & lastRow2) to Range("$C$7:$C$" & lastRow2) if that's your intended range.
Hope this helps!
Option Explicit
Sub Test()
'Define workbooks
Dim wb2FileName As Variant, wb3FileName As Variant
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
'Count last rows in columns
Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
'Variables
Dim lookFor As Range, lookForRange As Range, srchRange As Range
Dim tempCount As Integer, lastCount As Integer
'Open up all workbooks to work on
Set wb1 = ThisWorkbook
wb2FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Customer Order Data Worksheet", MultiSelect:=False)
If wb2FileName <> False Then
Set wb2 = Workbooks.Open(wb2FileName)
Else
MsgBox "No wb2, exiting"
Exit Sub
End If
wb3FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Source Reference File (Weights)", MultiSelect:=False)
If wb3FileName <> False Then
Set wb3 = Workbooks.Open(wb3FileName)
Else
MsgBox "No wb3, exiting"
Exit Sub
End If
'Find the last row in the customer data workbook and the source weights workbook
lastRow2 = wb2.Sheets(1).Cells(Rows.Count, 3).End(xlUp).Row
lastRow3 = wb3.Sheets(1).Cells(Rows.Count, 3).End(xlUp).Row
'Use VLOOKUP to enter in weights from the reference sheet into the customer order data sheet, then multiply by the quantity
lastCount = lastRow2
For tempCount = 1 To lastCount
Set lookFor = wb2.Sheets(1).Cells(tempCount + 6, 10) ' value to find
Set srchRange = wb3.Sheets(1).Range("$B$2:$C$" & lastRow3) 'source
wb2.Sheets(1).Cells(tempCount + 6, 16).Value = Application.WorksheetFunction.VLookup(lookFor, srchRange, 2, False)
wb2.Sheets(1).Cells(tempCount + 6, 17).Value = wb2.Sheets(1).Cells(tempCount + 6, 11).Value * wb2.Sheets(1).Cells(tempCount + 6, 16).Value
Next
'Delete top 5 rows from the final sheet and insert new header
wb1.Sheets(1).Rows("1:5").Delete
wb1.Sheets(1).Cells(1, 12).Value = "Weights"
'Find the last row on the final sheet
lastRow1 = wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Enter in the weights data into the final sheet
lastCount = lastRow1
Set lookForRange = wb2.Sheets(1).Range("$C$2:$C$" & lastRow2) 'Range of values to lookup
Set srchRange = wb2.Sheets(1).Range("$Q$2:$Q$" & lastRow2)
For tempCount = 1 To lastCount
Set lookFor = wb1.Sheets(1).Cells(tempCount + 1, 11) ' value to find
wb1.Sheets(1).Cells(tempCount + 1, 12).Value = Application.WorksheetFuction.SumIf(lookForRange, lookFor, srchRange)
Next
End Sub

loop through adding values in a range (5x5 for example) of row and columns in multiple sheets and dump in one particular sheet

I have multiple sheets in a single workbook with values in 5 rows and 5 columns in each sheet. I need to add the corresponding cell values (eg: D5) in each sheet and dump it in a new sheet in its D5. I could do it for one particular cell, but I'm confused on how to do it in nested for loops. I've only been doing vba for a day.. so please help. Thanks.
Sub Macro1()
Dim i, val
'Select worksheets
For i = 7 To Sheets.Count
val = val + Sheets(i).Range("e6")
Next
Sheets("Summation").Range("e6") = val
End Sub
Is this what you want?
Sub Sample()
Dim ws As Worksheet, wsSumry As Worksheet
Dim startRow As Long, StartCol As Long
Dim i As Long, j As Long
Dim ar(1 To 4, 1 To 4) As Variant
'~~> Start row and start column
startRow = 2: StartCol = 2
'~~> Summary sheet
Set wsSumry = Sheet1
'~~> Looping through each worksheet
For Each ws In ThisWorkbook.Worksheets
'~~> Check if it is not the summary sheet
If ws.Name <> wsSumry.Name Then
'~~> Loop through the row and columns and
'~~> Store it in an array
For i = startRow To (startRow + 3)
For j = StartCol To (StartCol + 3)
ar(i - 1, j - 1) = ar(i - 1, j - 1) + ws.Cells(i, j)
Next j
Next i
End If
Next
'~~> Write array to summary sheet
wsSumry.Range("B2").Resize(UBound(ar), UBound(ar)).Value = ar
End Sub
Screenshot
You can use Copy and Add technique, cycling through each sheet that isn't the summisary sheet and then pasting its values in to the final sheet (while adding them) - something like:
Dim b As Worksheet
Set b = ThisWorkbook.Worksheets("Sheet4")
b.range("A1:A2").clear
For Each a In ThisWorkbook.Sheets
If Not a.Name = b.Name Then
a.Range("A1:A2").Copy
b.Range("A1:A2").PasteSpecial operation:=xlAdd
End If
Next
Obviously your range can be defined in place of "A1:A2"
I'm sure there's a more "code" way of adding arrays together but in Excel this might prove good for you.

Open, rename and run same excel macro on multiple excel files

I have about 50 Excel sheets in one folder, on my MacBook - (/Users/myusername/Desktop/Tidy/folder")
I want to perform the following Macro on them all:
Sub SmartCopy()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long
Set s1 = Sheets("s1")
Set s2 = Sheets("s2")
N = s1.Cells(Rows.Count, "Y").End(xlUp).Row
j = 1
For i = 1 To N
If s1.Cells(i, "Y").Value = "No" Then
Else
s1.Cells(i, "Y").EntireRow.Copy s2.Cells(j, 1)
j = j + 1
End If
Next i
End Sub
I am struggling to get the sheets to open, almost like the filepath won't be recognised, also each sheet is named like this:
business-listing-002-w-site.csv
with one tab:
business-listing-002-w-site.csv
So I also need to either 1) rename the sheet each time 2) have the macro just open the only sheet in the workbook.
I want to copy all data from all workbooks into one master. I did try to add my Macro and adapt this one but just can't get it to run at all.
link to another post
You need to define the workbook (file), not just the sheet(tab).
Dim filePath as String
Dim sheetStart as String
Dim count as Integer
Dim sheetEnd as string
Dim thisSheet as Worksheet
Dim wb1 as Workbook
Dim ws1 as Worksheet
filePath = "/Users/myusername/Desktop/Tidy/folder/"
sheetStart = "business-listing-"
sheetEnd = "-w-site"
Set thisSheet as ThisWorkbook.Worksheets("Sheet1")
For count = 1 to 44 'the range of sheets you have
Set wb1 = Workbooks.Open(filePath & sheetStart & format(count, "000") & sheetEnd & ".csv")
Set ws1 = wb1.Worksheets(sheetStart & format(count, "000") & sheetEnd)
'move the ranges you want from ws1 to thisSheet
wb1.close
next count
each time the code loops, it will change the filename being opened and the sheet that it is looking for.
I assume you either know or can find how to copy a range from ws1 to the next available row of thisSheet based on the original code you provided.
edited with improved code based on comments

Vba copy row to another workbook based on condition

I have 2 wb and need to copy value to another wb based on condition:
If the value in the column F of wb2 appears in column F of wb1, then I need to copy value in the column G of wb2 to column G of wb1. The code is below:
Dim LtRow As Long
Dim m As Long, n As Long
With wb2.Worksheets.Item(1)
LtRow = .Cells(.Rows.Count, "G").End(xlUp).Row
End With
With ThisWorkbook.Sheets.Item(2)
n = .Cells(.Rows.Count, "G").End(xlUp).Row + 1
End With
For m = 1 To LtRow
With wb2.Worksheets.Item(1)
If .Cells(m, 6).Value = ThisWorkbook.Sheets.Item(2).Cells(m, 6).Value Then
.Rows(m).Copy Destination:=ThisWorkbook.Sheets.Item(2).Range("G" & n)
n = n + 1
End If
End With
Next m
I don't know why the code didn't work at all! Where is the problem in my code?
EDIT:
To see what your excel files look like wasn't an option for what you are trying to do. Especially because in you have many empty rows. Anyway, this works for me:
Sub CopyConditions()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim Wb1Ws2 As Worksheet
Dim Wb2Ws1 As Worksheet
Set Wb1 = ThisWorkbook
Set Wb1Ws2 = ThisWorkbook.Sheets("Differences")
'open the wb2
Dim FullFilePathAndName As Variant
Dim StrOpenFileTypesDrpBx As String
Let StrOpenFileTypesDrpBx = "xls (*.xls),*.xls,CSV (*.CSV),*.CSV,Excel (*.xlsx),*.xlsx,OpenOffice (*.ods),*.ods,All Files (*.*),*.*,ExcelMacros (*.xlsm),.xlsm"
Let FullFilePathAndName = Application.GetOpenFilename(StrOpenFileTypesDrpBx, 1, "Compare this workbook ""(" & Wb1.Name & ")"" to...?", , False) 'All optional Arguments
If FullFilePathAndName = False Then
MsgBox "You did't select a file!", vbExclamation, "Canceled"
Exit Sub
Else
Set Wb2 = Workbooks.Open(FullFilePathAndName)
Set Wb2Ws1 = Wb2.Sheets("Sheet1")
End If
Dim rCell As Range
Dim sCell As Range
'loop through each cell in column F until row30 because with the empty cells in the column we can't use Rows.count
For Each rCell In Wb1Ws2.Range(Wb1Ws2.Cells(1, 6), Wb1Ws2.Cells(30, 6)) 'Wb1Ws2.Cells(Wb1Ws2.Rows.Count, 6).End(xlUp))
'if the cell column F is equal to a cell in wb2 sheet1 column L
For Each sCell In Wb2Ws1.Range(Wb2Ws1.Cells(3, 12), Wb2Ws1.Cells(Wb2Ws1.Rows.Count, 12).End(xlUp))
If sCell = rCell Then
rCell.Offset(0, 1) = sCell.Offset(0, 1)
End If
Next sCell
Next rCell
End Sub
How does it go for you?

loop through columns on worksheet, copy data to new worksheet in new workbook - im stuck

I have a workbook that consists of several worksheets all with the same column headers. The rows in each worksheet identify an employee task and other task information. Columns starting at AB - BE containing an employee’s title as the column name along with email address in the row if they assisted in that task. Some of the rows are in a particular column if that employee roll has not touched that task.
I am looking to do the following.
Create a new workbook for new worksheets to be added
Loop through AB:BE and create a new worksheet in the new workbook with the column header name as the worksheet name
Filter this column (example: AB) to only include data that is in this list and not blanks
Copy this column data (AB as an example) into this new worksheet
Also copy Rows B, F, H from original worksheet to this new worksheet
Clear the filters on the main worksheet
Loop to next column (example AC) , repeat with creation of new worksheet in the workbook
I have done this in the past with rows just fine – I am having issues conceptually thinking about how this should work.
Does anyone have any examples? I have searched google for a few days and can get close in some areas however it does not scale well / loop on the data well.
Note: This could also be done with an Advanced Filter. That allows a filtered range to be copied to a new sheet.
I'm not sure I'm entirely understanding the sheet layout, but here's some basic code to create a new sheet for each column AB:BE, then for each row in column AB that is not empty, copy that cell value, along with the value in columns B, F, and H to a row in that new worksheet. Repeating then for columns AC:BE.
Sub CopyRoles()
Dim nSheet As Integer
Dim nTasks As Integer
Dim nSourceRow As Long
Dim nDestRow As Long
Dim wkb As Workbook
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Set wksSource = ActiveSheet
Set wkb = Workbooks.Add
For nTasks = wksSource.Range("AB1").Column To wksSource.Range("BE1").Column
nSheet = nTasks - wksSource.Range("AB1").Column + 1
With wkb.Sheets
If .Count < nSheet Then ' Checks if sheet count on wkb exceeded
Set wksDest = .Add(after:=.Item(.Count), Type:=xlWorksheet)
Else
Set wksDest = .Item(nSheet) ' Keeps from having empty sheets
End If
wksDest.Name = wksSource.Cells(1, nTasks)
End With
With wksSource
wksDest.Cells(1, 1) = "E-mail address" ' Add header row to sheet
wksDest.Cells(1, 2) = .Cells(.UsedRange.Row, 2) ' Col B
wksDest.Cells(1, 3) = .Cells(.UsedRange.Row, 6) ' Col F
wksDest.Cells(1, 4) = .Cells(.UsedRange.Row, 8) ' Col H
nDestRow = 2
For nSourceRow = .UsedRange.Row + 1 To .UsedRange.Rows.Count
If .Cells(nSourceRow, nTasks).Value <> "" Then
wksDest.Cells(nDestRow, 1).FormulaR1C1 = _
.Cells(nSourceRow, nTasks).Value
wksDest.Cells(nDestRow, 2).FormulaR1C1 = _
.Range("B" & nSourceRow).Value
wksDest.Cells(nDestRow, 3).FormulaR1C1 = _
.Range("F" & nSourceRow).Value
wksDest.Cells(nDestRow, 4).FormulaR1C1 = _
.Range("H" & nSourceRow).Value
nDestRow = nDestRow + 1
End If
Next nSourceRow
End With
Next nTasks
wkb.SaveAs
End Sub