is anything more you guys required in this thread ?
Posts by Rmrekoj
-
-
Quote
Hi team,
i am working with the merge all workbook into one master file.. require your help here to copy header at the top of Master sheet...
also it would be very great full if the code get converted easy and faster with the help of Ubound array .
Code
Display MoreSub Merger() Dim wb As Workbook, sh As Workbook, fPath As String, fName As String 'Set sh = ThisWorkbook.Sheets(1) Set sh = Workbooks.Add fPath = ThisWorkbook.path 'If files are in a different directory than master, replace path here If Right(fPath, 1) <> "\" Then fPath = fPath & "\" 'Make sure separator is on end of path fName = Dir(fPath & "*Specific*net*.xl*") 'get all Excel files in directory Application.ScreenUpdating = False 'fName = Dir(fPath & "*.xl*") 'get all Excel files in directory Do If fName <> ThisWorkbook.Name Then Set wb = Workbooks.Open(fPath & fName) With wb.Sheets(1) If Application.CountA(.Rows(2)) > 0 Then .UsedRange.Offset(1).Copy sh.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2) End If End With wb.Close False End If fName = Dir Loop While fName <> "" sh.SaveAs Filename:=fPath & "Specific_Master_" & Format(Now, "dd-mmm-yyyy-(hh-mm-ss)") & ".xlsx" sh.Close SaveChanges:=False End Sub -
I have two open sheets with some of matching column header
so first sheet is my main sheet where some column I need to fill from other sheet
For ex
I have column name ( Name, Address, Contact No) ( this is fixed row)
and second sheet I have many columns but I want only require columns data
in this sheet I have column name ( this row can be different not stable)
(Name, last name, Contact No, Date, DOB, Address, etc…..)so I need just that 3 columns data to my main sheet till last row
only this data ( Name, Address, Contact No)thanks
-
hi there
should i make new request for that?
-
i think i have exceed the free limit.
-
i think i have exceed the free limit.
-
Hi team,
is there any way to set macro in ribbon tab like working in the quick access bar.... but issue is ribbon macro is showing in all of my excel file ,, and i dont want that.
quick access is working good but showing small icon .. is there any option available please let me know
thanks so much
-
-
Hi team,
Require you help to get the data from 4 workbook and fill the data to main sheet as per requirement.
and the unique name will help to find the range and offset will set the value to empty place.
thanks so much...
-
please find the file sir
-
sure will share it u sir
-
Hi team,
I am working on a query and require your help on..
as I have a database of group and sequence and with help of that I have to format my new data...
Thanks
-
by using below code I am able to reduce the above macro time..still m searching a progress bar
CodeCells.Select Selection.Copy Sheets.Add After:=ActiveSheet Cells.Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False -
hello carim can u help
-
Hi team did u get any solution on that
-
Hi team,
with the help of your support I got the below code.
and its working fine but taking too much time as its providing data from 4 excel file.so request you to can u please help me out...
1) can u make it shorter & faster as this is huge due to which taking time.
2) I would like to set progress bar so that I can wait accordingly rather that pressing key
QuoteDisplay More
Option Explicit
Option Compare TextSub Dayw()
Dim Mbook, Bbook As Workbook
Dim ws As Worksheet
Dim Path, d, fname As String
Dim moxi, Tty, dnum, cnum, Esum, Dly, Dlyn, h, jd, m, j, k, pk, i As Integer
Dim kData, fnd, c, Rng, kng, myrange1, myrange2, sng, ar As Range
Dim count(1 To 10), Lr, countt As Long
Dim cb As Variant
Dim Myarr, p, col1, col2, vKEYs, tmp As Variant
Dim y()
Dim dic As ObjectApplication.EnableEvents = False
Application.ScreenUpdating = FalseSet Mbook = ThisWorkbook.ActiveSheet
jd = 1
On Error Resume Nexth = WorksheetFunction.Match("*key*", Mbook.Range("A:A"), 0)
Path = ThisWorkbook.Path & Application.PathSeparator
fname = Dir(Path & "*.xls", vbNormal)
Do Until fname = ""
If fname <> ThisWorkbook.Name Then
Set Bbook = Workbooks.Open(Filename:=Path & fname, UpdateLinks:=0, ReadOnly:=False)For Each ws In Sheets
Set fnd = ws.UsedRange.Find("*Fac*", LookIn:=xlValues, LookAt:=xlPart)
If Not fnd Is Nothing Then
ws.Activate
Exit For
End If
Next ws
m = h + jdActiveSheet.AutoFilterMode = False
Myarr = Array(m, m + 5, m + 10, m + 15, m + 26)
Tty = WorksheetFunction.Match("*mode*" & "*Typ*", ActiveSheet.Range("1:1"), 0)
Set cb = ActiveSheet.Range("1:1").Find(what:="Capac*", LookIn:=xlValues, LookAt:=xlWhole)
If cb Is Nothing Then
MsgBox "Please Create Capac Column", , fname
Exit Sub
End If
cb = cb.Column
dnum = WorksheetFunction.Match("*mydata*" & "*cancell*", ActiveSheet.Range("1:1"), 0)
cnum = WorksheetFunction.Match("*Mydata1*" & "*Num*", ActiveSheet.Range("1:1"), 0)
If cnum = "" Then
cnum = WorksheetFunction.Match("*mydata3*" & "*Num*", ActiveSheet.Range("1:1"), 0)
End If
Esum = WorksheetFunction.Match("*mydata4*", ActiveSheet.Range("1:1"), 0)
Set Dly = ActiveSheet.Range("1:1").Find(what:="data?", LookIn:=xlValues, LookAt:=xlWhole)
If Dly Is Nothing Then
Set Dly = ActiveSheet.Range("1:1").Find(what:="data1*" & "*data2", LookIn:=xlValues, LookAt:=xlWhole)
End IfDlyn = Dly.Column
Set col1 = ActiveSheet.Range("1:1").Find(what:="*Alloc*ctual*", LookIn:=xlValues, LookAt:=xlWhole)
If col1 Is Nothing Then
Set col1 = ActiveSheet.Range("1:1").Find(what:="*Alloc*", LookIn:=xlValues, LookAt:=xlWhole)
End If
col1 = col1.Column
Set col2 = ActiveSheet.Range("1:1").Find(what:="*Perfor*ctual*", LookIn:=xlValues, LookAt:=xlWhole)
If col2 Is Nothing Then
Set col2 = ActiveSheet.Range("1:1").Find(what:="*Perfor*", LookIn:=xlValues, LookAt:=xlWhole)
End If
col2 = col2.Column
moxi = Application.IfError(Application.Match(Array("*Basic*", "Plan*"), Range("1:1"), 0), 0)
If moxi > 0 Then
ActiveSheet.UsedRange.AutoFilter field:=moxi, Criteria1:="*mode of*", Operator:=xlFilterValues
Else
End If
With ActiveSheet
Set kData = .UsedRangeWith kData
.AutoFilter field:=cnum, Criteria1:="<>", Criteria2:="<> 0", Operator:=xlFilterValues
Lr = ActiveSheet.Cells(ActiveSheet.Rows.count, "A").End(xlUp).RowSet Rng = ActiveSheet.Range(Cells(2, col1), Cells(Lr, col2))
Set dic = CreateObject("scripting.dictionary")For Each c In Rng
If c.Value Like "*ancell*" = False And c.Value Like "*Unuse*" = False And c.Value Like "*-NA*" = False And c.Value Like "" = False And c.Value Like "*not*ubmitt*" = False Then
dic(c.Value) = c.Value
End If
NextIf Bbook.Name Like "*XX1*" Then
d = "A65"
ElseIf Bbook.Name Like "*XX2*" Thend = "A79"
ElseIf Bbook.Name Like "*XX3*" Thend = "A88"
ElseIf Bbook.Name Like "*XX4*" Thend = "A93"
Else
End If
vKEYs = dic.keysFor i = LBound(vKEYs) + 1 To UBound(vKEYs)
For j = LBound(vKEYs) To UBound(vKEYs) - 1
If vKEYs(j) > vKEYs(i) Then
tmp = vKEYs(j)
vKEYs(j) = vKEYs(i)
vKEYs(i) = tmp
End If
Next j
Next i
i = 0
Mbook.Range(d).Resize(dic.count) = Application.Transpose(vKEYs)
Set kng = Mbook.Range(d, Mbook.Range(d).End(xlDown)).AutoFilter field:=dnum, Criteria1:="N", Operator:=xlFilterValues
If Bbook.Name Like "*XX3*" Then.AutoFilter field:=cnum, Criteria1:="<>", Operator:=xlFilterValues
Set myrange2 = ActiveSheet.Range(Cells(2, col1), Cells(Lr, col1)).SpecialCells(xlCellTypeVisible)
.AutoFilter field:=cnum, Criteria1:="<> 0", Operator:=xlFilterValues
Set myrange1 = ActiveSheet.Range(Cells(2, col2), Cells(Lr, col2)).SpecialCells(xlCellTypeVisible)
Else
Set myrange2 = ActiveSheet.Range(Cells(2, col1), Cells(Lr, col1)).SpecialCells(xlCellTypeVisible)
Set myrange1 = ActiveSheet.Range(Cells(2, col2), Cells(Lr, col2)).SpecialCells(xlCellTypeVisible)
End IfFor Each sng In kng
For Each ar In myrange1
countt = countt + Application.WorksheetFunction.CountIf(ar, sng)
Next ari = i + 1
ReDim Preserve y(1 To 2, 1 To i)
y(1, i) = countt
countt = 0
Next sng
i = 0
For Each sng In kng
For Each ar In myrange2
countt = countt + Application.WorksheetFunction.CountIf(ar, sng)
Next ar
i = i + 1
y(2, i) = countt
countt = 0
Next sngMbook.Range(d).Offset(0, 11).Resize(i, 2) = Application.Transpose(y)
i = 0Set Rng = ActiveSheet.Range(Cells(2, cb), Cells(Lr, cb))
With ActiveSheet
count(10) = Application.Sum(Rng.SpecialCells(xlCellTypeVisible))
count(9) = Application.Sum(Columns(Esum).SpecialCells(xlCellTypeVisible))
End With
.AutoFilter field:=Tty, Criteria1:="D*", Operator:=xlFilterValues
.AutoFilter field:=dnum, Criteria1:="N", Operator:=xlFilterValues
With ActiveSheet
count(6) = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1
count(8) = Application.Sum(Columns(Esum).SpecialCells(xlCellTypeVisible))
End With.AutoFilter field:=Dlyn, Criteria1:="*N*", Operator:=xlFilterValues
With ActiveSheet
count(5) = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1
count(7) = Application.Sum(Columns(Esum).SpecialCells(xlCellTypeVisible))
End With.AutoFilter field:=Dlyn
.AutoFilter field:=Tty, Criteria1:="P*", Operator:=xlFilterValues
.AutoFilter field:=dnum, Criteria1:="N", Operator:=xlFilterValuesWith ActiveSheet
count(2) = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1
count(4) = Application.Sum(Columns(Esum).SpecialCells(xlCellTypeVisible))
End With.AutoFilter field:=Dlyn, Criteria1:="*N*", Operator:=xlFilterValues
With ActiveSheet
count(1) = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.count - 1
count(3) = Application.Sum(Columns(Esum).SpecialCells(xlCellTypeVisible))
End WithEnd With
End WithBbook.Close False
For Each p In Myarr
For j = 12 To 13k = k + 1
ActiveSheet.Cells(p, j).Value = count(k)
Next j
Next pFor pk = 1 To k
count(pk) = 0
Next pk
k = 0
jd = jd + 1
Application.EnableEvents = False
Application.ScreenUpdating = False
End If
fname = Dir()Loop
End Sub -
Thanks [USER="138669"]Mumps[/USER] its working as I wanted.. thanks so much
-
Hi team,
I want to search a word inside a workbook and open that sheet as active sheet
plz help
-
Hello Sir please do me a favor
-
Hello Sir please do me a favor