this is my code where users can select multiple files and then they are compared with headers in master file and then data is copy pasted. the problem is that i do not know how to reference the workbooks from the array to run the code, one workbook at a time. previously for a single workbook i used the activate statement but i do not know how to do it for multiple workbooks in the array. the book names are stored in arrNames. Temp calc is the sheet where all the data has to be stored. any suggestions ?
thanks,
Mathew
Sub Test()
Dim lastCol, lastRow As Long, k As Long, a As Variant, b As Variant, cmpRng As Range
Dim mastCol As Long, mastRng As Range, n As Long
Dim Wbk As Workbook
Dim fileone
Dim SelectedFiles As Object
Dim arrNames As Variant
Dim indx As Long
Application.ScreenUpdating = False
Sheets("Temp Calc").Select
'Clear existing sheet data except headers
Rows(1).Offset(1, 0).Resize(Rows.Count - 1).ClearContents
arrNames = Application.GetOpenFilename(Filefilter:="Workbooks (*.xlsx),*.xlsx", MultiSelect:=True)
For i = 1 To UBound(arrNames, 1)
Worksheets("Temp Calc").Select
lastCol = Worksheets("Temp Calc").Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = Worksheets("Temp Calc").Cells(Rows.Count, 1).End(xlDown).Row
Set cmpRng = Range(Cells(1, 1), Cells(1, lastCol))
a = cmpRng
mastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Set mastRng = Range(Cells(1, 1), Cells(1, mastCol))
b = mastRng
For k = 1 To lastCol
For n = 1 To mastCol
If UCase(a(1, k)) = UCase(b(1, n)) Then
Here i need the code to open workbook in array
Worksheets("Sheet1").Range(Cells(2, n), Cells(lastRow, n)).Copy
Windows("Dashboard_for_Roshan.xlsm").Activate
Worksheets("Temp Calc").Select
Cells(2, k).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Exit For
End If
Next
Next
Next
'Else
'End If
Application.ScreenUpdating = True
Exit Sub
'Next
End Sub
you could try
sPath="C:\"
workbooks(sPath & arrNames(i)).open
where i is your loop counter through the array returned by GetOpenFileName and arrNames is your array
Related
I'm trying to merge several sheets into one.
Configuration
DataSheet1 : First sheet
DataSheet2 : Second sheet
ConsolidatedSheet : Consolidated sheet
Code
Set consolidatedSheet = Worksheets("ConsolidatedSheet")
consolidatedSheet.Activate
startRow = 2
startCol = 1
Worksheets("DataSheet1").Activate
lastRow = Cells(Rows.Count, startCol).End(xlUp).row
lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
consolidatedSheet.Range("A" & consolidatedSheet.Cells(Rows.Count, 1).End(xlUp).row + 1)
Worksheets("DataSheet2").Activate
lastRow = Cells(Rows.Count, startCol).End(xlUp).row
lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
consolidatedSheet.Range("A" & consolidatedSheet.Cells(Rows.Count, 1).End(xlUp).row + 1)
Issue
Two arrays are created in the consolidated sheet. It means I can't sort on the consolidated sheet.
How do I copy data as values instead of arrays?
Sub consSheets()
Dim ws As Worksheet
With Worksheets("ConsolidatedSheet")
.Cells.Delete ' clear the assignment sheet first
For Each ws In Sheets(Array("DataSheet1", "DataSheet2"))
ws.Cells(2, 1).CurrentArray.Copy
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Next ws
End With
Application.CutCopyMode = False ' "clears" the clipboard
End Sub
Edit2: (not copy headers from DataSheet1 and DataSheet2 and keep existing header in ConsolidatedSheet)
Sub consSheets()
Dim ws As Worksheet
With Worksheets("ConsolidatedSheet")
.Rows("2:" & .UsedRange.Row + .UsedRange.Rows.Count).Delete ' clear (without header in Row 1) the assignment sheet first
For Each ws In Sheets(Array("DataSheet1", "DataSheet2"))
Set Rng = ws.Cells(2, 1).CurrentRegion
Set Rng = Intersect(Rng, Rng.Offset(1)) ' eliminate headers
If Not Rng Is Nothing Then
Rng.Copy
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End If
Next ws
End With
Application.CutCopyMode = False ' "clears" the clipboard
End Sub
I'm not sure what you mean by it creating arrays, and I don't think that code is actually the code using as it's not doing what you describe.
But here's something that does what your intending.
Option Explicit
Sub Test()
Dim cSht As Worksheet
Set cSht = Worksheets("ConsolidatedSheet")
Dim StartRow As Integer, StartCol As Integer
StartRow = 1
StartCol = 1
'Split out to a sub and don't need to repeat self
Call ConsolidateData(cSht, "DataSheet1", StartRow, StartCol, True)
Call ConsolidateData(cSht, "DataSheet2", StartRow, StartCol)
End Sub
Private Sub ConsolidateData(cSht As Worksheet, FromSheet As String, StartRow As Integer, StartCol As Integer, Optional IncludeHeader As Boolean)
Dim FromRow As Integer
If IncludeHeader Then
FromRow = StartRow
Else
FromRow = StartRow + 1
End If
With Worksheets(FromSheet)
lastrow = .Cells(.Rows.Count, StartCol).End(xlUp).Row
lastcol = .Cells(StartRow, .Columns.Count).End(xlToLeft).Column
'Just transfering value is faster then copy, but doesn't bring formatting
cSht.Cells(cSht.Rows.Count, 1).End(xlUp).Resize(lastrow - FromRow, lastcol - StartCol).Value2 = .Range(.Cells(FromRow, StartCol), .Cells(lastrow, lastcol)).Value2
End With
End Sub
I have a few non-contiguous ranges that may vary in size each time it is run. I would like to take each of the ranges and copy and paste them onto their own individual worksheets (one range per sheet).
My code currently works for the first range and sheet. After the second sheet is created, the ranges are highlighted, but the first range is again copied and pasted onto the second sheet, instead of the corresponding second range. Then, the third sheet is created, but again, only the first range is copied and pasted onto this sheet. I know something is wrong with my looping, but I can't figure out where.
I have exhausted all of my resources. I just can't figure out why the loop isn't getting to the other 2 ranges.
'Get current sheet name
Dim activeSheetName As String
activeSheetName = ActiveSheet.Name
'Create a new sheet to reformat existing data
Dim newSheetName As String
newSheetName = (activeSheetName + "_Data")
Dim filterRange As range
Dim areasCount As Integer
For Each a In filterRange.Areas
Sheets(newSheetName).Select
filterRange.Select
range(Selection, Selection.End(xlToRight)).Select
areasCount = Selection.Areas.Count
With a
For i = 2 To areasCount + 1
Selection.Copy
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = a.Cells(1, 1).Value
.range("A1").Value = a.Offset(, 1)
range("A50").Select
Selection.PasteSpecial paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:= False, Transpose:=False
Application.CutCopyMode = False
End With
Next i
End With
Next a
I have tried to incorporate the following code I found in a book, but no such luck.
Dim SelAreas() As range
Dim pasteRange As range
Dim upperLeft As range
Dim numAreas As Long, i As Long
Dim topRow As Long, leftCol As Long
Dim rowOffset As Long, colOffset As Long
If TypeName(Selection) <> "Range" Then Exit Function
numAreas = Selection.Areas.Count
ReDim SelAreas(1 To numAreas)
For i = 1 To numAreas
Set SelAreas(i) = Selection.Areas(i)
Next
topRow = ActiveSheet.Rows.Count
leftCol = ActiveSheet.Columns.Count
For i = 1 To numAreas
If SelAreas(i).Row < topRow Then topRow = SelAreas(i).Row
If SelAreas(i).Column < leftCol Then leftCol = SelAreas(i).Column
Next
Set upperLeft = Cells(topRow, leftCol)
On Error Resume Next
Set pasteRange = range("A50")
On Error GoTo 0
If TypeName(pasteRange) <> "Range" Then Exit Function
Set pasteRange = pasteRange.range("A1")
For i = 1 To numAreas
rowOffset = SelAreas(i).Row - topRow
colOffset = SelAreas(i).Column - leftCol
SelAreas(i).Copy
range("A1").Value = pasteRange.Offset(rowOffset, colOffset)
Next i
For Each a In filterRange.Areas
Sheets(newSheetName).Select
range(a, a.End(xlToRight)).Copy
With a
If filterRange Is Nothing Then
MsgBox ("Value not present in this workbook.")
Else
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = a.Cells(1, 1).Value
.range("A1").Value = a.Offset(, 1)
range("A50").Select
ActiveSheet.paste
End With
range("A10:A49").Select
range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
range("A1").Select
End If
End With
Next a
I have a lot of Excels from different modules with different column layouts (purchase orders, Sales orders, Production orders, etc.).
I want to delete every row that contains value "Invoiced".
I was able to create simple code where only one column ("J") is checked, but I need whole worksheet to be checked.
Private Sub BoomShakalaka_Click()
Application.ScreenUpdating = False
ow = Cells(Rows.Count, "J").End(xlUp).Row
For r = ow To 1 Step -1
If Cells(r, "J") = "Invoiced" Then Rows(r).Delete
Next
Application.ScreenUpdating = True
End Sub
I expect that after I run this function, it will check the whole workbook and delete every row which contains the value "Invoiced".
I want to add here my idea of using arrays instead, so you only access the worksheet when you read the data, and then when you delete the rows.
Option Explicit
Sub deleteInvoiced()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Dim wb As Workbook: Set wb = ActiveWorkbook 'or ThisWorkbook, or the name of the workbook where data is
Dim ws As Worksheet
Dim R As Long, C As Long, X As Long
Dim lRow As Long, lCol As Long
Dim arrData
For Each ws In wb.Worksheets
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row 'Get the last row in the current sheet
lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Get the last column in the current sheet
arrData = ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol))
For R = UBound(arrData) To LBound(arrData) Step -1
For C = UBound(arrData, 2) To LBound(arrData, 2) Step -1
If arrData(R, C) = "Invoiced" Or arrData(R, C) = "Delivered" Then
'Now delete the rows
ws.Cells(R, C).EntireRow.Delete
Exit For 'Exit here in case multiple "Invoice" or "Delivered" in the same row (WHY?!!). Thanks #Brian.
End If
Next C
Next R
Next ws
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
PS: There is no error handling, but i leave that to you.
Loop through every cell within every row within activesheet.usedrange:
Private Sub BoomShakalaka_Click()
For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
For Each c In ActiveSheet.UsedRange.Rows(r).Cells
If c.Value = "Invoiced" Then
c.EntireRow.Delete
Exit For
End If
Next c
Next r
End Sub
Alternatively, you could do it by using find. This will be faster than my other answer if there is a lot of data:
sub BoomShakalaka_Click()
screenupdating = false
On Error GoTo exitSub
ActiveSheet.UsedRange.SpecialCells(xlLastCell).select
do while true
Cells.Find(What:="Invoiced", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
, SearchFormat:=False).Activate
Selection.EntireRow.Delete
Loop
exitSub:
screenupdating = True
Exit Sub
end sub
Here's another interesting way. It assumes your data starts in cell A1 and is contiguous.
Option Explicit
Public Sub TestDeleteInvoiced()
Dim wb As Workbook
Dim ws As Worksheet
Dim arr As Variant
Dim arr1() As Variant
Dim row As Long
Dim col As Long
Dim i As Long
Set wb = ActiveWorkbook
i = 1
ReDim arr1(1 To 14)
For Each ws In wb.Worksheets
arr = ws.Range("A1").CurrentRegion
For row = UBound(arr, 1) To LBound(arr, 1) Step -1
For col = UBound(arr, 2) To LBound(arr, 2) Step -1
If arr(row, col) = "Invoiced" Then
arr1(i) = row & ":" & row
i = i + 1
'This If statement ensures that the Join function is less than 255 characters.
If i = 15 Then
ws.Range(Join(arr1, ", ")).EntireRow.Delete
ReDim arr1(1 To 14)
i = 1
End If
Exit For
End If
Next col
Next row
ReDim Preserve arr1(1 To i - 1)
ws.Range(Join(arr1, ", ")).EntireRow.Delete
Next ws
End Sub
Note: Deleting a range of non-contiguous rows cannot exceed a 255 character parameter. Link
Currently trying to append all cells in each row into the first cell of that row, and iterate through every row. Problem is I'm dealing with ~3000 rows with about 20 columns of data in each row. Is there any better way to append all cells in a row into one single cell without using a for loop? That could narrow down the code to a single for loop and may speed up the process.
Tried making a nested for loop that iterates through every row then every column per row. It works, but takes far too long when dealing with a large amount of data.
Sub AppendToSingleCell()
Dim value As String
Dim newString As String
Dim lastColumn As Long
Dim lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To lastRow
lastColumn = Cells(j, Columns.Count).End(xlToLeft).Column
For i = 2 To lastColumn
If IsEmpty(Cells(j, i)) = False Then
value = Cells(j, i)
newString = Cells(j, 1).value & " " & value
Cells(j, 1).value = newString
Cells(j, i).Clear
End If
Next i
Next j
End Sub
Load everything into a variant array and loop that instead of the range. load the output into another variant array and then put that data as one back in the sheet.
Sub AppendToSingleCell()
With ActiveSheet
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
Dim lastColumn As Long
lastColumn = .Cells.Find(What:="*", After:=.Range("a1"), LookIn:=xlValue, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim dtaArr() As Variant
dtaArr = .Range(.Cells(1, 2), .Cells(lastRow, lastColumn)).value
Dim otArr() As Variant
ReDim otArr(1 To lastRow, 1 To 1)
Dim i As Long
For i = LBound(dtaArr, 1) To UBound(dtaArr, 1)
For j = LBound(dtaArr, 2) To UBound(dtaArr, 2)
If dtaArr(i, j) <> "" Then otArr(i, 1) = otArr(i, 1) & dtaArr(i, j) & " "
Next j
otArr(i, 1) = Application.Trim(otArr(i, 1))
Next i
.Range(.Cells(1, 2), .Cells(lastRow, lastColumn)).Clear
.Range(.Cells(1, 1), .Cells(lastRow, 1)).value = otArr
End With
End Sub
It's a bit long, but pretty straight forward.
Explanation inside the code's comments.
Code
Option Explicit
Sub AppendToSingleCell()
Dim newString As String
Dim LastRow As Long, LastColumn As Long
Dim Sht As Worksheet
Dim FullArr As Variant, MergeCellsArr As Variant
Dim i As Long, j As Long
Set Sht = ThisWorkbook.Sheets("Sheet1") ' <-- rename "Sheet1" to your sheet's name
With Sht
LastRow = FindLastRow(Sht) ' call sub that finds last row
LastColumn = FindLastCol(Sht) ' call sub that finds last column
' populate array with enitre range contents
FullArr = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
ReDim MergeCellsArr(1 To LastRow) ' redim 1-D array for results (same number of rows as in the 2-D array)
' looping through array is way faster than interfacing with your worksheet
For i = 1 To UBound(FullArr, 1) ' loop rows (1st dimension of 2-D array)
newString = FullArr(i, 1)
For j = 2 To UBound(FullArr, 2) ' loop columns (2nd dimension of 2-D array)
If IsEmpty(FullArr(i, j)) = False Then
newString = newString & " " & FullArr(i, j)
End If
Next j
MergeCellsArr(i) = newString ' read new appended string to new 1-D array
Next i
' paste entire array to first column
.Range("A1").Resize(UBound(MergeCellsArr)).value = MergeCellsArr
End With
End Sub
'=======================================================================
Function FindLastCol(Sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
Exit Function
End If
End With
End Function
'=======================================================================
Function FindLastRow(Sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.Row
Else
MsgBox "Error! worksheet is empty", vbCritical
Exit Function
End If
End With
End Function
If you're interested in a shorter solution.... It assumes your data begins in cell A1.
Public Sub CombineColumnData()
Dim arr As Variant
Dim newArr() As Variant
Dim varTemp As Variant
Dim i As Long
arr = ActiveSheet.Range("A1").CurrentRegion.Value
ReDim newArr(1 To UBound(arr, 1))
For i = LBound(arr, 1) To UBound(arr, 1)
varTemp = Application.Index(arr, i, 0)
newArr(i) = Join(varTemp, "")
Next i
With ActiveSheet.Range("A1")
.CurrentRegion.Clear
.Resize(UBound(arr, 1), 1) = Application.Transpose(newArr)
End With
End Sub
Hello all i get error 1004 when i run the following code. basically the code compares my sheet to sheet in other workbooks and copies the data. i know this error is simple and i can figure it out but i am on a deadline.. please advise
Sub test()
Dim lastCol, lastRow As Long, k, e As Long, a As Variant, b As Variant, cmpRng As Range
Dim mastCol As Long, mastRng As Range, n As Long
Dim Wbk As Workbook
Dim file As String
Dim SelectedFiles As Object
Dim filename As Variant
Dim indx As Long
Dim t As Integer
ChDrive "G:\" ' To set the drive where the files are located.
ChDir "g:\work" 'To set the folder where the files are located. This is done to save time locating the folder through pop up box always.
Application.ScreenUpdating = False
Sheets("Temp Calc").Select
'Clear existing sheet data ecept header.
Rows(1).Offset(1, 0).Resize(Rows.Count - 1).ClearContents
filename = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xlsx), *.xlsx", Title:="Get File", MultiSelect:=True)
Worksheets("Temp Calc").Select
lastCol = Worksheets("Temp Calc").Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = Worksheets("Temp Calc").Cells(Rows.Count, 1).End(xlDown).Row
Set cmpRng = Range(Cells(1, 1), Cells(1, lastCol))
a = cmpRng
mastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Set mastRng = Range(Cells(1, 1), Cells(1, mastCol))
b = mastRng
For t = 1 To UBound(filename)
Workbooks.Open (filename(t))
For k = 1 To lastCol
For n = 1 To mastCol
If UCase(a(1, k)) = UCase(b(1, n)) Then
Worksheets("Sheet1").Range(Cells(2, n), Cells(lastRow, n)).Copy
Windows("Dashboard_for_Roshan.xlsm").Activate
Worksheets("Temp Calc").Select
Cells(2,k).PasteSpecial Paste:=xlPasteAll,Operation:=xlNone,SkipBlanks:=False,Transpose:=False
****< I get an error for the above line >****
Exit For
End If
Next
Next
Next t
Application.ScreenUpdating = True
End Sub
replace
Worksheets("Temp Calc").Select
Cells(2,k).PasteSpecial Paste:=xlPasteAll,Operation:=xlNone,SkipBlanks:=False,Transpose:=False
with
Application.Goto Worksheets("Temp Calc").Cells(2, k)
ActiveSheet.Paste