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
Related
I have a spreadsheet with values starting at A5 and running across to column AI, there could be any number of entries to the rows.
Row A contains an Item code (e.g. 000-0000)
I am looking to produce some code to complete the following two actions:
If column AI = yes, then copy entire row and paste below. With every copy add a sequential alphabetised letter to the code in column A (e.g. 000-0000a)
Any help would be greatly appreciated. Everything i've found expands to copying to another sheet and i'm struggling to break down the code.
Thanks
Edit:
Please see below current code I have been trying to get to work which works up to the point of copying the row however fails to paste it.
Sub NewItems(c As Range)
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngNewItems = objWorksheet.Range("A5:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngNewItems.Cells
objWorksheet.Select
If rngCell.Value <> "Yes" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngNewItems = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
So there are lots of things to address with your code. Many of which I have touched on. But the main thing to observe is that you are testing Column A not Column AI for the presence of "Yes" - so there may not be a match hence no copy.
As the paste destination is determined by a concatenation to create a sheet name you should have a test to ensure that sheet exists.
For testing I simply ensured a sheet called Sheet1a existed, that Sheet1 cell A5 had "a" in it, and there was a "Yes" in column AI. This could be improved but is enough to get you going.
This line is looping column A:
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Whereas this line is testing column AI:
If rngCell.Offset(, 35).Value <> "Yes"
Note <> means Not Equal as opposed to =
So perhaps you wanted:
If rngCell.Offset(, 35).Value = "Yes"
Consider the following re-write.
Option Explicit
Public Sub NewItems() 'c As Range) 'I have commented out parameter which isn't currently used.
Dim rngBurnDown As Range ' not used but also not declared
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
Dim objNewSheet As Worksheet
Dim lastRowTargetSheet As Long
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
Dim lastRow As Long
lastRow = objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Dim copiedRange As Range 'for union
For Each rngCell In rngNewItems.Cells
'Debug.Print rngCell.Address 'shows where looping
If rngCell.Offset(, 35).Value = "Yes" Then
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
Dim nextTargetCell As Range
lastRowTargetSheet = objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set nextTargetCell = objNewSheet.Range("A" & lastRowTargetSheet)
rngCell.EntireRow.Copy nextTargetCell
Set objNewSheet = Nothing 'clear inside loop as you are setting in loop
lastRowTargetSheet = 0
Set nextTargetCell = Nothing
End If
Next rngCell
objWorksheet.Cells(1, 1).Select
End Sub
As for your lettering:
There are lots of examples online to generate these. Here is one way, by #harfang, from here:
Sub List_A_to_ZZZZ()
Dim i As Long
For i = 1 To 20 ' I have shortened this QHarr. Original end was 475254 ' ColXL("ZZZZ")
Debug.Print Right("---" & XLcL(i), 4)
Next i
End Sub
Function XLcL(ByVal N As Long) As String
Do While N > 0
XLcL = Chr(vbKeyA + (N - 1) Mod 26) & XLcL
N = (N - 1) \ 26
Loop
End Function
Function ColXL(ByVal abc As String) As Long
abc = Trim(Replace(UCase(abc), "-", ""))
Do While Len(abc)
ColXL = ColXL * 26 + (Asc(abc) - vbKeyA + 1)
abc = Mid(abc, 2)
Loop
End Function
I have an excel file in drive "D".I would like to copy the data from workbook
"raw" from sheet1 to the another workbook "SC" in sheet "BW".
I am using the below code, to extract the data from one workbook and pasting it to another.
Sub extract()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Dim LastCell As Range
Dim LastRow As Long
CopyCol = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X", ",")
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LCell = Selection.SpecialCells(xlCellTypeLastCell).Address
LCC = Selection.SpecialCells(xlCellTypeLastCell).Column
LCR = Selection.SpecialCells(xlCellTypeLastCell).Row
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Student\Jenny\Raw.xlsx")
For Count = 0 To UBound(CopyCol)
Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & LCR)
If Count = 0 Then
Set CopyRange = temp
Else
Set CopyRange = Union(CopyRange, temp)
End If
Next
CopyRange.Copy
y.Sheets("BW").Range("A5").PasteSpecial
x.Close
End Sub
This code is workin, but the problem is , in my sheet "sheet1" I have my data starting from A4, and would like to copy the data in destination sheet "BW" from A5.
The current code, paste the copied data from A7. How can I modify such a way that it pastes the copied data from A5.
Any lead would be helpful.
In Set temp try 4 instead of 1 as
Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & LCR)
How I can select an particular sheet (Sheet Result) from source sheet. ?
Use
With x.Sheets("Result")
.
.
.
End With
or
x.Sheets("Result"). or whatever you are trying.
You have many unused and undeclared variables. Your updated code may look something like this:
Option Explicit
Sub extract()
Dim x As Workbook, y As Workbook
Dim temp As Range, CopyRange As Range
Dim LR As Long, LC As Long, LCR As Long, Count As Long
Dim copycol
copycol = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X", ",")
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Student\Jenny\Raw.xlsx")
With x.Sheets("Result")
LCR = .Cells(.Rows.Count, 1).End(xlUp).Row
For Count = 0 To UBound(copycol)
Set temp = .Range(copycol(Count) & "4:" & copycol(Count) & LCR)
If Count = 0 Then
Set CopyRange = temp
Else
Set CopyRange = Union(CopyRange, temp)
End If
Next
CopyRange.Copy
y.Sheets("BW").Range("A5").PasteSpecial
End With
x.Close
End Sub
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?
GIVEN
a) A workbook (MainWorkBook) with 2 worksheets:
Main1: To enter the start and end date, to select (up to) 15 (3 x 5) values from 15 different dropdown menus, and 17 parameters that can be selected with a checkbox (The form control checkbox is linked to the underlying cell ($B10:$B26)).
Main2: To copy the results (Starting at B2).
b) Many workbooks (DataWorkBook) for several companies (CompanyXX) that come in several 'versions' (VersionXX), that each have several worksheets (DataWorkSheet: TypeXX).
PURPOSE
The idea is to import (paste) all of the data from the (data) workbooks into the "Main2" worksheet of the (main) workbook based on the selections that were made on the "Main1" worksheet: start/end date, companies, versions, types, and the parameters that were selected by the checkboxes.
See screenshots below:
QUESTION
What is working thus far, is that I'm able to open the correct workbook(s) at the correct worksheet, and I'm able to copy/paste pre-set rows of data (Code has been removed in the example below), but I'm still not able to copy/paste data for the selected rows (The rows selected by the checkboxes) between start and end date...
CODE (ATTEMPT)
Sub ImportData()
Dim MainWorkBook As Workbook
Dim DataWorkBook As Workbook
Dim MainWorkSheet As Worksheet
Dim DataWorkSheet As Worksheet
Dim i As Long
Dim Type As String
Dim j As Long
Dim StartDate As Date
Dim EndDate As Date
Dim DataRange As Range
Dim Data As Range
Dim TargetRow As Long
Dim TargetColumn As Long
Dim ChkBox As Shape
Application.ScreenUpdating = False
Set MainWorkBook = ActiveWorkbook
Set MainWorkSheet = MainWorkBook.Worksheets("Main1")
With MainWorkBook.ActiveSheet
StartDate = Cells(3, 3).Value
EndDate = Cells(4, 3).Value
For i = 3 To 7
If MainWorkSheet.Cells(6, i).Value <> "" Then
Type = MainWorkSheet.Cells(8, i).Value
Set DataWorkBook = Workbooks.Open("D:\ 'Some folders' \" & .Cells(6,
i).Value & "-" & .Cells(30, 2) & "-" & .Cells(7, i).Value & ".xlsx")
DataWorkBook.Worksheets(Type).Select
TargetRow = 2
TargetColumn = 2
j = 1
For Each ChkBox In MainWorkSheet.Shapes
If ChkBox.Type = msoFormControl Then
If ChkBox.FormControlType = xlCheckBox Then
If ChkBox.ControlFormat.Value = xlOn Then
Set DataWorkSheet = DataWorkBook.Worksheets(Tomato)
Set DataRange = Application.Intersect(DataWorkSheet.Range("B4:SZ4"),
DataWorkSheet.UsedRange)
For Each Data In DataRange.Cells
If Data.Value >= StartDate And Data.Value <= EndDate Then
Set TargetWorkSheet = MainWorkBook.Worksheets("Main2")
Data.Offset(j, 0).Resize(1, 1).Copy _
TargetWorkSheet.Cells(TargetRow, TargetColumn)
TargetRow = TargetRow + 1
End If
Next Data
TargetColumn = TargetColumn + 1
End If
End If
End If
Next ChkBox
On Error Resume Next
End If
DataWorkBook.Close savechanges:=False
Next i
End With
Application.ScreenUpdating = True
End Sub
Anybody who wants to give it a shot? :-)
Any help is appreciated!
NOBODY?
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